Merge branch 'master' into tests

Author: pepeiborra

.github/workflows/nix.yml

@@ -62,7 +62,7 @@ jobs:
         extra_nix_config: |
           experimental-features = nix-command flakes
         nix_path: nixpkgs=channel:nixos-unstable
-    - uses: cachix/cachix-action@v11
+    - uses: cachix/cachix-action@v12
       with:
         name: haskell-language-server
         # Disable pushing, we will do that in job `build`
@@ -96,7 +96,7 @@ jobs:
         extra_nix_config: |
           experimental-features = nix-command flakes
         nix_path: nixpkgs=channel:nixos-unstable
-    - uses: cachix/cachix-action@v11
+    - uses: cachix/cachix-action@v12
       with:
         name: haskell-language-server
         authToken: ${{ secrets.HLS_CACHIX_AUTH_TOKEN }}

.hlint.yaml

@@ -59,6 +59,7 @@
     - Development.IDE.Graph.Internal.Database
     - Development.IDE.Graph.Internal.Paths
     - Development.IDE.Graph.Internal.Profile
+    - Development.IDE.Graph.Internal.Types
     - Ide.Types
     - Test.Hls
     - Test.Hls.Command

ghcide/ghcide.cabal

@@ -62,7 +62,7 @@ library
         focus,
         ghc-trace-events,
         Glob,
-        haddock-library >= 1.8 && < 1.11,
+        haddock-library >= 1.8 && < 1.12,
         hashable,
         hie-compat ^>= 0.3.0.0,
         hls-plugin-api ^>= 1.5,

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

@@ -55,7 +55,6 @@ import qualified Development.IDE.Types.Logger                 as L
 
 import qualified Data.Binary                                  as B
 import qualified Data.ByteString.Lazy                         as LBS
-import qualified Data.HashSet                                 as HSet
 import           Data.List                                    (foldl')
 import qualified Data.Text                                    as Text
 import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)
@@ -256,7 +255,7 @@ setSomethingModified vfs state keys reason = do
     atomically $ do
         writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
         modifyTVar' (dirtyKeys $ shakeExtras state) $ \x ->
-            foldl' (flip HSet.insert) x keys
+            foldl' (flip insertKeySet) x keys
     void $ restartShakeSession (shakeExtras state) vfs reason []
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool

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

@@ -178,7 +178,7 @@ import           System.Time.Extra
 data Log
   = LogCreateHieDbExportsMapStart
   | LogCreateHieDbExportsMapFinish !Int
-  | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath)
+  | LogBuildSessionRestart !String ![DelayedActionInternal] !(KeySet) !Seconds !(Maybe FilePath)
   | LogBuildSessionRestartTakingTooLong !Seconds
   | LogDelayedAction !(DelayedAction ()) !Seconds
   | LogBuildSessionFinish !(Maybe SomeException)
@@ -197,7 +197,7 @@ instance Pretty Log where
       vcat
         [ "Restarting build session due to" <+> pretty reason
         , "Action Queue:" <+> pretty (map actionName actionQueue)
-        , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog)
+        , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog)
         , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ]
     LogBuildSessionRestartTakingTooLong seconds ->
         "Build restart is taking too long (" <> pretty seconds <> " seconds)"
@@ -279,7 +279,7 @@ data ShakeExtras = ShakeExtras
     ,clientCapabilities :: ClientCapabilities
     , withHieDb :: WithHieDb -- ^ Use only to read.
     , hiedbWriter :: HieDbWriter -- ^ use to write
-    , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent)
+    , persistentKeys :: TVar (KeyMap GetStalePersistent)
       -- ^ Registery for functions that compute/get "stale" results for the rule
       -- (possibly from disk)
     , vfsVar :: TVar VFS
@@ -290,7 +290,7 @@ data ShakeExtras = ShakeExtras
     -- We don't need a STM.Map because we never update individual keys ourselves.
     , defaultConfig :: Config
       -- ^ Default HLS config, only relevant if the client does not provide any Config
-    , dirtyKeys :: TVar (HashSet Key)
+    , dirtyKeys :: TVar KeySet
       -- ^ Set of dirty rule keys since the last Shake run
     }
 
@@ -324,7 +324,7 @@ getPluginConfig plugin = do
 addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules ()
 addPersistentRule k getVal = do
   ShakeExtras{persistentKeys} <- getShakeExtrasRules
-  void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal)
+  void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal)
 
 class Typeable a => IsIdeGlobal a where
 
@@ -399,7 +399,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
           pmap <- readTVarIO persistentKeys
           mv <- runMaybeT $ do
             liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k
-            f <- MaybeT $ pure $ HMap.lookup (Key k) pmap
+            f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap
             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
           case mv of
@@ -509,7 +509,7 @@ deleteValue
   -> STM ()
 deleteValue ShakeExtras{dirtyKeys, state} key file = do
     STM.delete (toKey key file) state
-    modifyTVar' dirtyKeys $ HSet.insert (toKey key file)
+    modifyTVar' dirtyKeys $ insertKeySet (toKey key file)
 
 recordDirtyKeys
   :: Shake.ShakeValue k
@@ -518,7 +518,7 @@ recordDirtyKeys
   -> [NormalizedFilePath]
   -> STM (IO ())
 recordDirtyKeys ShakeExtras{dirtyKeys} key file = do
-    modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file)
+    modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file)
     return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do
         addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file)
 
@@ -594,7 +594,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
         positionMapping <- STM.newIO
         knownTargetsVar <- newTVarIO $ hashed HMap.empty
         let restartShakeSession = shakeRestart recorder ideState
-        persistentKeys <- newTVarIO HMap.empty
+        persistentKeys <- newTVarIO mempty
         indexPending <- newTVarIO HMap.empty
         indexCompleted <- newTVarIO 0
         indexProgressToken <- newVar Nothing
@@ -637,7 +637,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
 
     -- monitoring
     let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras
-        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras)
+        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras)
         readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)
         readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras)
         readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb
@@ -797,10 +797,10 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
         workRun restore = withSpan "Shake session" $ \otSpan -> do
           setTag otSpan "reason" (fromString reason)
           setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued)
-          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk)
+          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk)
           let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)
           res <- try @SomeException $
-            restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs
+            restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs
           return $ do
               let exception =
                     case res of
@@ -890,7 +890,7 @@ garbageCollectKeys label maxAge checkParents agedKeys = do
             = atomicallyNamed "GC" $ do
                 gotIt <- STM.focus (Focus.member <* Focus.delete) k values
                 when gotIt $
-                   modifyTVar' dk (HSet.insert k)
+                   modifyTVar' dk (insertKeySet k)
                 return $ if gotIt then (counter+1, k:keys) else st
             | otherwise = pure st
 
@@ -1068,7 +1068,7 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe
     extras <- getShakeExtras
     let diagnostics ver diags = do
             traceDiagnostics diags
-            updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags
+            updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags
     defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file
 defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do
     let diagnostics _ver diags = do
@@ -1087,7 +1087,7 @@ defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (o
     extras <- getShakeExtras
     let diagnostics ver diags = do
             traceDiagnostics diags
-            updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags
+            updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags
     defineEarlyCutoff' diagnostics (==) key file old mode $ op key file
 
 defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()
@@ -1160,7 +1160,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
                     (encodeShakeValue bs) $
                     A res
-        liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file)
+        liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)
         return res
   where
     -- Highly unsafe helper to compute the version of a file
@@ -1199,15 +1199,16 @@ updateFileDiagnostics :: MonadIO m
   -> ShakeExtras
   -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
   -> m ()
-updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv} current =
+updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 =
   liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do
     addTag "key" (show k)
     let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
         uri = filePathToUri' fp
         addTagUnsafe :: String -> String -> String -> a -> a
         addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v
         update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
-        update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (T.pack $ show k) new store
+        update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (renderKey k) new store
+        current = second diagsFromRule <$> current0
     addTag "version" (show ver)
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always
@@ -1230,6 +1231,22 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
                             LSP.sendNotification LSP.STextDocumentPublishDiagnostics $
                                 LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags)
                  return action
+    where
+        diagsFromRule :: Diagnostic -> Diagnostic
+        diagsFromRule c@Diagnostic{_range}
+            | coerce ideTesting = c
+                {_relatedInformation =
+                    Just $ List [
+                        DiagnosticRelatedInformation
+                            (Location
+                                (filePathToUri $ fromNormalizedFilePath fp)
+                                _range
+                            )
+                            (T.pack $ show k)
+                            ]
+                }
+            | otherwise = c
+
 
 newtype Priority = Priority Double
 

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

@@ -23,6 +23,7 @@ import           GHC.Generics
 
 import           GHC
 
+import           Data.Bifunctor               (second)
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Orphans  ()
 import           Development.IDE.GHC.Util
@@ -179,8 +180,12 @@ haddockToMarkdown (H.DocHeader (H.Header level title))
 
 haddockToMarkdown (H.DocUnorderedList things)
   = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)
-haddockToMarkdown (H.DocOrderedList things)
-  = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)
+haddockToMarkdown (H.DocOrderedList things) =
+#if MIN_VERSION_haddock_library(1,11,0)
+  '\n' : (unlines $ map ((\(num, str) -> show num ++ ". " ++ str) . second (trimStart . splitForList . haddockToMarkdown)) things)
+#else
+  '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)
+#endif
 haddockToMarkdown (H.DocDefList things)
   = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
 

ghcide/src/Development/IDE/Types/Shake.hs

@@ -26,7 +26,7 @@ import           Data.Typeable                        (cast)
 import           Data.Vector                          (Vector)
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes       (FileVersion)
-import           Development.IDE.Graph                (Key (..), RuleResult)
+import           Development.IDE.Graph                (Key (..), RuleResult, newKey)
 import qualified Development.IDE.Graph                as Shake
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
@@ -75,7 +75,7 @@ isBadDependency x
     | otherwise = False
 
 toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key
-toKey = (Key.) . curry Q
+toKey = (newKey.) . curry Q
 
 fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath)
 fromKey (Key k)
@@ -91,7 +91,7 @@ fromKeyType (Key k) = case typeOf k of
     _ -> Nothing
 
 toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key
-toNoFileKey k = Key $ Q (k, emptyFilePath)
+toNoFileKey k = newKey $ Q (k, emptyFilePath)
 
 newtype Q k = Q (k, NormalizedFilePath)
     deriving newtype (Eq, Hashable, NFData)

ghcide/test/exe/Main.hs

@@ -2393,6 +2393,34 @@ haddockTests
              , ""
              ]
           )
+      , testCase "ordered list" $ checkHaddock
+          (unlines
+             [ "may require"
+             , "different precautions:"
+             , ""
+             , "  1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
+             , "        that calls 'unsafePerformIO'.  If the call is inlined,"
+             , "        the I\\/O may be performed more than once."
+             , ""
+             , "  2. Use the compiler flag @-fno-cse@ to prevent common sub-expression"
+             , "        elimination being performed on the module."
+             , ""
+             ]
+          )
+          (unlines
+             [ ""
+             , ""
+             , "may require"
+             , "different precautions: "
+             , "1. Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "
+             , "  that calls  `unsafePerformIO` .  If the call is inlined,"
+             , "  the I/O may be performed more than once."
+             , ""
+             , "2. Use the compiler flag  `-fno-cse`  to prevent common sub-expression"
+             , "  elimination being performed on the module."
+             , ""
+             ]
+          )
       ]
   where
     checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

hls-graph/hls-graph.cabal

@@ -47,6 +47,8 @@ library
     Development.IDE.Graph.Classes
     Development.IDE.Graph.Database
     Development.IDE.Graph.Rule
+    Development.IDE.Graph.KeyMap
+    Development.IDE.Graph.KeySet
     Development.IDE.Graph.Internal.Action
     Development.IDE.Graph.Internal.Options
     Development.IDE.Graph.Internal.Rules
@@ -82,6 +84,7 @@ library
     , transformers
     , unliftio
     , unordered-containers
+    , text
 
   if flag(embed-files)
         cpp-options: -DFILE_EMBED

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

@@ -1,8 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
 module Development.IDE.Graph(
-    shakeOptions,
+      shakeOptions,
     Rules,
     Action, action,
-    Key(..),
+    Key(.., Key),
+    newKey, renderKey,
     actionFinally, actionBracket, actionCatch, actionFork,
     -- * Configuration
     ShakeOptions(shakeAllowRedefineRules, shakeExtra),
@@ -18,9 +20,13 @@ module Development.IDE.Graph(
     -- * Actions for inspecting the keys in the database
     getDirtySet,
     getKeysAndVisitedAge,
+    module Development.IDE.Graph.KeyMap,
+    module Development.IDE.Graph.KeySet,
     ) where
 
 import           Development.IDE.Graph.Database
+import           Development.IDE.Graph.KeyMap
+import           Development.IDE.Graph.KeySet
 import           Development.IDE.Graph.Internal.Action
 import           Development.IDE.Graph.Internal.Options
 import           Development.IDE.Graph.Internal.Rules

hls-graph/src/Development/IDE/Graph/Database.hs

@@ -79,7 +79,7 @@ shakeGetBuildEdges :: ShakeDatabase -> IO Int
 shakeGetBuildEdges (ShakeDatabase _ _ db) = do
     keys <- getDatabaseValues db
     let ress = mapMaybe (getResult . snd) keys
-    return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress
+    return $ sum $ map (lengthKeySet . getResultDepsDefault mempty . resultDeps) ress
 
 -- | Returns an approximation of the database keys,
 --   annotated with how long ago (in # builds) they were visited

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

@@ -39,7 +39,7 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 alwaysRerun :: Action ()
 alwaysRerun = do
     ref <- Action $ asks actionDeps
-    liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>)
+    liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>)
 
 -- No-op for now
 reschedule :: Double -> Action ()
@@ -121,7 +121,7 @@ apply ks = do
     stack <- Action $ asks actionStack
     (is, vs) <- liftIO $ build db stack ks
     ref <- Action $ asks actionDeps
-    liftIO $ modifyIORef ref (ResultDeps (toList is) <>)
+    liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>)
     pure vs
 
 -- | Evaluate a list of keys without recording any dependencies.