Merge branch 'master' into batch-load-multi-read

Author: soulomoon

cabal.project

@@ -8,7 +8,7 @@ packages:
          ./hls-test-utils
 
 
-index-state: 2025-06-16T09:44:13Z
+index-state: 2025-07-09T16:51:20Z
 
 tests: True
 test-show-details: direct

ghcide-test/data/multi-unit/a-1.0.0-inplace

@@ -16,3 +16,6 @@ base
 text
 -XHaskell98
 A
++RTS
+-A32M
+-RTS

ghcide-test/data/multi-unit/c-1.0.0-inplace

@@ -17,3 +17,5 @@ a-1.0.0-inplace
 base
 -XHaskell98
 C
++RTS
+-A32M

ghcide-test/exe/CradleTests.hs

@@ -117,7 +117,11 @@ simpleSubDirectoryTest =
 
 multiTests :: FilePath -> [TestTree]
 multiTests dir =
-  [simpleMultiTest dir, simpleMultiTest2 dir, simpleMultiTest3 dir, simpleMultiDefTest dir]
+  [ simpleMultiTest dir
+  , simpleMultiTest2 dir
+  , simpleMultiTest3 dir
+  , simpleMultiDefTest dir
+  ]
 
 multiTestName :: FilePath -> String -> String
 multiTestName dir name = "simple-" ++ dir ++ "-" ++ name

ghcide/ghcide.cabal

@@ -73,7 +73,7 @@ library
     , Glob
     , haddock-library              >=1.8      && <1.12
     , hashable
-    , hie-bios                     ^>=0.15.0
+    , hie-bios                     ^>=0.16.0
     , hie-compat                   ^>=0.3.0.0
     , hiedb                        ^>= 0.7.0.0
     , hls-graph                    == 2.11.0.0

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

@@ -56,6 +56,7 @@ import           Development.IDE.Types.HscEnvEq      (HscEnvEq)
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import qualified HIE.Bios                            as HieBios
+import qualified HIE.Bios.Cradle.Utils               as HieBios
 import           HIE.Bios.Environment                hiding (getCacheDir)
 import           HIE.Bios.Types                      hiding (Log)
 import qualified HIE.Bios.Types                      as HieBios
@@ -1023,6 +1024,121 @@ memoIO op = do
                 return (Map.insert k res mp, res)
             Just res -> return (mp, res)
 
+unit_flags :: [Flag (CmdLineP [String])]
+unit_flags = [defFlag "unit"  (SepArg addUnit)]
+
+addUnit :: String -> EwM (CmdLineP [String]) ()
+addUnit unit_str = liftEwM $ do
+  units <- getCmdLineState
+  putCmdLineState (unit_str : units)
+
+-- | Throws if package flags are unsatisfiable
+setOptions :: GhcMonad m
+    => NormalizedFilePath
+    -> ComponentOptions
+    -> DynFlags
+    -> FilePath -- ^ root dir, see Note [Root Directory]
+    -> m (NonEmpty (DynFlags, [GHC.Target]))
+setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do
+    ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts)
+    case NE.nonEmpty units of
+      Just us -> initMulti us
+      Nothing -> do
+        (df, targets) <- initOne (map unLoc theOpts')
+        -- 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.
+        --
+        -- When we have a singleComponent 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
+        let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp)
+        let special_target = Compat.mkSimpleTarget df abs_fp
+        pure $ (df, special_target : targets) :| []
+    where
+      initMulti unitArgFiles =
+        forM unitArgFiles $ \f -> do
+          args <- liftIO $ expandResponse [f]
+          -- The reponse files may contain arguments like "+RTS",
+          -- and hie-bios doesn't expand the response files of @-unit@ arguments.
+          -- Thus, we need to do the stripping here.
+          initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args
+      initOne this_opts = do
+        (dflags', targets') <- addCmdOpts this_opts dflags
+        let dflags'' =
+                case unitIdString (homeUnitId_ dflags') of
+                     -- cabal uses main for the unit id of all executable packages
+                     -- This makes multi-component sessions confused about what
+                     -- options to use for that component.
+                     -- Solution: hash the options and use that as part of the unit id
+                     -- This works because there won't be any dependencies on the
+                     -- executable unit.
+                     "main" ->
+                       let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts)
+                           hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash))
+                       in setHomeUnitId_ hashed_uid dflags'
+                     _ -> dflags'
+
+        let targets = makeTargetsAbsolute root targets'
+            root = case workingDirectory dflags'' of
+              Nothing   -> compRoot
+              Just wdir -> compRoot </> wdir
+        let dflags''' =
+              setWorkingDirectory root $
+              disableWarningsAsErrors $
+              -- disabled, generated directly by ghcide instead
+              flip gopt_unset Opt_WriteInterface $
+              -- disabled, generated directly by ghcide instead
+              -- also, it can confuse the interface stale check
+              dontWriteHieFiles $
+              setIgnoreInterfacePragmas $
+              setBytecodeLinkerOptions $
+              disableOptimisation $
+              Compat.setUpTypedHoles $
+              makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory
+              dflags''
+        return (dflags''', targets)
+
+setIgnoreInterfacePragmas :: DynFlags -> DynFlags
+setIgnoreInterfacePragmas df =
+    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
+
+disableOptimisation :: DynFlags -> DynFlags
+disableOptimisation df = updOptLevel 0 df
+
+setHiDir :: FilePath -> DynFlags -> DynFlags
+setHiDir f d =
+    -- override user settings to avoid conflicts leading to recompilation
+    d { hiDir      = Just f}
+
+setODir :: FilePath -> DynFlags -> DynFlags
+setODir f d =
+    -- override user settings to avoid conflicts leading to recompilation
+    d { objectDir = Just f}
+
+getCacheDirsDefault :: String -> [String] -> IO CacheDirs
+getCacheDirsDefault prefix opts = do
+    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)
+    return $ CacheDirs dir dir dir
+    where
+        -- Create a unique folder per set of different GHC options, assuming that each different set of
+        -- GHC options will create incompatible interface files.
+        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts)
+
+-- | Sub directory for the cache path
+cacheDir :: String
+cacheDir = "ghcide"
+
 ----------------------------------------------------------------------------------------------------
 
 data PackageSetupException

ghcide/src/Development/IDE/Spans/Common.hs

@@ -190,11 +190,10 @@ haddockToMarkdown (H.DocOrderedList things) =
 haddockToMarkdown (H.DocDefList things)
   = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
 
--- we cannot render math by default
-haddockToMarkdown (H.DocMathInline _)
-  = "*cannot render inline math formula*"
-haddockToMarkdown (H.DocMathDisplay _)
-  = "\n\n*cannot render display math formula*\n\n"
+haddockToMarkdown (H.DocMathInline s)
+  = "`" ++ s ++ "`"
+haddockToMarkdown (H.DocMathDisplay s)
+  = "\n```latex\n" ++ s ++ "\n```\n"
 
 -- TODO: render tables
 haddockToMarkdown (H.DocTable _t)

haskell-language-server.cabal

@@ -282,7 +282,7 @@ library hls-cabal-plugin
     , transformers
     , unordered-containers  >=0.2.10.0
     , containers
-    , cabal-add
+    , cabal-add             ^>=0.1
     , process
     , aeson
     , Cabal

hls-graph/src/Development/IDE/Graph/Internal/Key.hs

@@ -34,6 +34,7 @@ module Development.IDE.Graph.Internal.Key
     ) where
 
 --import Control.Monad.IO.Class ()
+import           Control.Exception             (evaluate)
 import           Data.Coerce
 import           Data.Dynamic
 import qualified Data.HashMap.Strict           as Map
@@ -85,8 +86,15 @@ newKey k = unsafePerformIO $ do
 
 lookupKeyValue :: Key -> KeyValue
 lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do
+  -- NOTE:
+  -- The reason for this evaluate is that the x, if not forced yet, is a thunk
+  -- that forces the atomicModifyIORef' in the creation of the new key. If it
+  -- isn't forced *before* reading the keyMap, the keyMap will only obtain the new
+  -- key (x) *after* the IntMap is already copied out of the keyMap reference,
+  -- i.e. when it is forced for the lookup in the IntMap.
+  k <- evaluate x
   GlobalKeyValueMap _ im _ <- readIORef keyMap
-  pure $! im IM.! x
+  pure $! im IM.! k
 
 {-# NOINLINE lookupKeyValue #-}
 

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs

@@ -63,6 +63,7 @@ import           GHC                                    (addAnns, ann)
 
 #if MIN_VERSION_ghc(9,9,0)
 import           GHC                                    (NoAnn (..))
+import           GHC                                    (EpAnnComments (..))
 #endif
 
 ------------------------------------------------------------------------------
@@ -170,7 +171,7 @@ appendConstraint constraintT = go . traceAst "appendConstraint"
     constraint <- liftParseAST df constraintT
     constraint <- pure $ setEntryDP constraint (SameLine 1)
 #if MIN_VERSION_ghc(9,9,0)
-    let l'' = fmap (addParensToCtxt close_dp) l'
+    let l'' = moveCommentsToTheEnd $ fmap (addParensToCtxt close_dp) l'
 #else
     let l'' = (fmap.fmap) (addParensToCtxt close_dp) l'
 #endif
@@ -205,6 +206,26 @@ appendConstraint constraintT = go . traceAst "appendConstraint"
 
     return $ reLocA $ L lTop $ HsQualTy noExtField context ast
 
+#if MIN_VERSION_ghc(9,9,0)
+-- | This moves comment annotation toward the end of the block
+-- This is useful when extending a block, so the comment correctly appears
+-- after.
+--
+-- See https://github.com/haskell/haskell-language-server/issues/4648 for
+-- discussion.
+--
+-- For example, the following element, @(Foo) => -- hello@, when introducing an
+-- additionnal constraint, `Bar`, instead of getting `@(Foo, Bar) => -- hello@,
+-- we get @(Foo, -- hello Bar) =>@
+--
+-- This is a bit painful that the pretty printer is not able to realize that it
+-- introduces the token `=>` inside the comment and instead does something with
+-- meaning, but that's another story.
+moveCommentsToTheEnd :: EpAnn ann -> EpAnn ann
+moveCommentsToTheEnd (EpAnn entry anns (EpaComments priors)) = EpAnn entry anns (EpaCommentsBalanced { priorComments = [], followingComments = priors})
+moveCommentsToTheEnd (EpAnn entry anns (EpaCommentsBalanced priors following)) = EpAnn entry anns (EpaCommentsBalanced { priorComments = [], followingComments = priors <> following})
+#endif
+
 liftParseAST
     :: forall ast l.  (ASTElement l ast, ExactPrint (LocatedAn l ast))
     => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast)
@@ -500,7 +521,7 @@ extendHiding symbol (L l idecls) mlies df = do
     Nothing -> do
 #if MIN_VERSION_ghc(9,11,0)
         let ann :: EpAnn (AnnList (EpToken "hiding", [EpToken ","]))
-            ann = noAnnSrcSpanDP0 
+            ann = noAnnSrcSpanDP0
 #elif MIN_VERSION_ghc(9,9,0)
         let ann = noAnnSrcSpanDP0
 #else