Fix progress counting (#1789)

Author: pepeiborra

ghcide/ghcide.cabal

@@ -365,7 +365,8 @@ test-suite ghcide-tests
         tasty-hunit,
         tasty-quickcheck,
         tasty-rerun,
-        text
+        text,
+        unordered-containers,
     if (impl(ghc >= 8.6))
       build-depends:
           record-dot-preprocessor,
@@ -379,6 +380,7 @@ test-suite ghcide-tests
         Development.IDE.Test.Runfiles
         Experiments
         Experiments.Types
+        Progress
     default-extensions:
         BangPatterns
         DeriveFunctor

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

@@ -7,6 +7,9 @@ module Development.IDE.Core.ProgressReporting
   -- utilities, reexported for use in Core.Shake
   , mRunLspT
   , mRunLspTCallback
+  -- for tests
+  , recordProgress
+  , InProgress(..)
   )
    where
 
@@ -18,7 +21,6 @@ import           Control.Monad.Trans.Class      (lift)
 import           Data.Foldable                  (for_)
 import           Data.Functor                   (($>))
 import qualified Data.HashMap.Strict            as HMap
-import           Data.Maybe                     (isJust)
 import qualified Data.Text                      as T
 import           Data.Unique
 import           Development.IDE.GHC.Orphans    ()
@@ -76,8 +78,14 @@ data InProgress = InProgress
 recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress
 recordProgress file shift InProgress{..} = case HMap.alterF alter file current of
     ((prev, new), m') ->
-        let todo' = if isJust prev then todo else todo + 1
-            done' = if new == 0 then done+1 else done
+        let (done',todo') =
+                case (prev,new) of
+                    (Nothing,0) -> (done+1, todo+1)
+                    (Nothing,_) -> (done,   todo+1)
+                    (Just 0, 0) -> (done  , todo)
+                    (Just 0, _) -> (done-1, todo)
+                    (Just _, 0) -> (done+1, todo)
+                    (Just _, _) -> (done  , todo)
         in InProgress todo' done' m'
   where
     alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x')

ghcide/test/exe/Main.hs

@@ -101,6 +101,7 @@ import qualified Language.LSP.Types                       as LSP
 import           Data.IORef.Extra                         (atomicModifyIORef_)
 import qualified Development.IDE.Plugin.HLS.GhcIde        as Ghcide
 import           Text.Regex.TDFA                          ((=~))
+import qualified Progress
 
 waitForProgressBegin :: Session ()
 waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case
@@ -5463,6 +5464,7 @@ unitTests = do
             actualOrder <- liftIO $ readIORef orderRef
 
             liftIO $ actualOrder @?= reverse [(1::Int)..20]
+     , Progress.tests
      ]
 
 testIde :: IDE.Arguments -> Session () -> IO ()

ghcide/test/exe/Progress.hs

@@ -0,0 +1,28 @@
+module Progress (tests) where
+
+import Development.IDE.Core.ProgressReporting
+import           Test.Tasty
+import           Test.Tasty.HUnit
+import qualified Data.HashMap.Strict as Map
+
+tests :: TestTree
+tests = testGroup "Progress"
+    [ reportProgressTests
+    ]
+
+reportProgressTests :: TestTree
+reportProgressTests = testGroup "recordProgress"
+    [ test "addNew"   addNew
+    , test "increase" increase
+    , test "decrease" decrease
+    , test "done" done
+    ]
+    where
+        p0 = InProgress 0 0 mempty
+        addNew = recordProgress "A" succ p0
+        increase = recordProgress "A" succ addNew
+        decrease = recordProgress "A" succ increase
+        done = recordProgress "A" pred decrease
+        model InProgress{..} =
+            (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current)
+        test name p = testCase name $ model p