fix hls-graph test

Author: soulomoon

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

@@ -55,7 +55,7 @@ newDatabase :: (String -> IO ()) ->  DBQue -> Dynamic -> TheRules -> IO Database
 newDatabase dataBaseLogger databaseQueue databaseExtra databaseRules = do
     databaseStep <- newTVarIO $ Step 0
     databaseThreads <- newTVarIO []
-    databaseValuesLock <- newTVarIO False
+    databaseValuesLock <- newTVarIO True
     databaseValues <- atomically SMap.new
     databaseRuntimeRevDep <- atomically SMap.new
     pure Database{..}

hls-graph/test/ActionSpec.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
 
 module ActionSpec where
 
@@ -8,7 +9,11 @@ import qualified Control.Concurrent                      as C
 import           Control.Concurrent.STM
 import           Control.Monad.IO.Class                  (MonadIO (..))
 import           Control.Monad.Trans.Cont                (evalContT)
-import           Development.IDE.Graph                   (shakeOptions)
+import           Data.Typeable                           (Typeable)
+import           Development.IDE.Graph                   (RuleResult,
+                                                          ShakeOptions,
+                                                          shakeOptions)
+import           Development.IDE.Graph.Classes           (Hashable)
 import           Development.IDE.Graph.Database          (shakeNewDatabase,
                                                           shakeRunDatabase,
                                                           shakeRunDatabaseForKeys)
@@ -23,9 +28,14 @@ import           Test.Hspec
 
 
 
+buildWithRoot :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Typeable value) => Database -> Stack -> f key -> IO (f Key, f value)
+buildWithRoot = build (newKey ("root" :: [Char]))
+shakeNewDatabaseWithLogger :: DBQue -> ShakeOptions -> Rules () -> IO ShakeDatabase
+shakeNewDatabaseWithLogger = shakeNewDatabase (const $ return ())
 
 itInThread :: String -> (DBQue -> IO ()) -> SpecWith ()
 itInThread name ex = it name $ evalContT $ do
+    -- thread <- withWorkerQueueSimpleRight (appendFile "hlg-graph-test.txt" . (++"\n") . show) "hls-graph test"
     thread <- withWorkerQueueSimpleRight (const $ return ()) "hls-graph test"
     liftIO $ ex thread
 
@@ -53,7 +63,7 @@ spec = do
                     return $ RunResult ChangedNothing "" r (return ())
     count <- C.newMVar 0
     count1 <- C.newMVar 0
-    db <- shakeNewDatabase q shakeOptions $ do
+    db <- shakeNewDatabaseWithLogger q shakeOptions $ do
       ruleSubBranch count
       ruleStep1 count1
     -- bootstrapping the database
@@ -74,18 +84,18 @@ spec = do
     c1 `shouldBe` 2
   describe "apply1" $  do
     itInThread "computes a rule with no dependencies" $ \q -> do
-      db <- shakeNewDatabase q shakeOptions ruleUnit
+      db <- shakeNewDatabaseWithLogger q shakeOptions ruleUnit
       res <- shakeRunDatabaseFromRight db $
         pure $ apply1 (Rule @())
       res `shouldBe` [()]
     itInThread "computes a rule with one dependency" $ \q -> do
-      db <- shakeNewDatabase q shakeOptions $ do
+      db <- shakeNewDatabaseWithLogger q shakeOptions $ do
         ruleUnit
         ruleBool
       res <- shakeRunDatabaseFromRight db $ pure $ apply1 Rule
       res `shouldBe` [True]
     itInThread "tracks direct dependencies" $ \q -> do
-      db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do
+      db@(ShakeDatabase _ _ theDb) <- shakeNewDatabaseWithLogger q shakeOptions $ do
         ruleUnit
         ruleBool
       let theKey = Rule @Bool
@@ -95,7 +105,7 @@ spec = do
       Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb
       resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())]
     itInThread "tracks reverse dependencies" $ \q -> do
-      db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase q shakeOptions $ do
+      db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabaseWithLogger q shakeOptions $ do
         ruleUnit
         ruleBool
       let theKey = Rule @Bool
@@ -105,33 +115,33 @@ spec = do
       Just KeyDetails {..} <- atomically $ STM.lookup (newKey (Rule @())) databaseValues
       keyReverseDeps `shouldBe` singletonKeySet (newKey theKey)
     itInThread "rethrows exceptions" $ \q -> do
-      db <- shakeNewDatabase q shakeOptions $ addRule $ \(Rule :: Rule ()) _old _mode -> error "boom"
+      db <- shakeNewDatabaseWithLogger q shakeOptions $ addRule $ \(Rule :: Rule ()) _old _mode -> error "boom"
       let res = shakeRunDatabaseFromRight db $ pure $ apply1 (Rule @())
       res `shouldThrow` anyErrorCall
     itInThread "computes a rule with branching dependencies does not invoke phantom dependencies #3423" $ \q -> do
       cond <- C.newMVar True
       count <- C.newMVar 0
-      (ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do
+      (ShakeDatabase _ _ theDb) <- shakeNewDatabaseWithLogger q shakeOptions $ do
         ruleUnit
         ruleCond cond
         ruleSubBranch count
         ruleWithCond
       -- build the one with the condition True
       -- This should call the SubBranchRule once
       -- cond rule would return different results each time
-      res0 <- build theDb emptyStack [BranchedRule]
+      res0 <- buildWithRoot theDb emptyStack [BranchedRule]
       snd res0 `shouldBe` [1 :: Int]
       incDatabase theDb Nothing
       -- build the one with the condition False
       -- This should not call the SubBranchRule
-      res1 <- build theDb emptyStack [BranchedRule]
+      res1 <- buildWithRoot theDb emptyStack [BranchedRule]
       snd res1 `shouldBe` [2 :: Int]
      -- SubBranchRule should be recomputed once before this (when the condition was True)
-      countRes <- build theDb emptyStack [SubBranchRule]
+      countRes <- buildWithRoot theDb emptyStack [SubBranchRule]
       snd countRes `shouldBe` [1 :: Int]
 
   describe "applyWithoutDependency" $ itInThread "does not track dependencies" $ \q -> do
-    db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do
+    db@(ShakeDatabase _ _ theDb) <- shakeNewDatabaseWithLogger q shakeOptions $ do
       ruleUnit
       addRule $ \Rule _old _mode -> do
           [()] <- applyWithoutDependency [Rule]

hls-graph/test/DatabaseSpec.hs

@@ -4,7 +4,8 @@ module DatabaseSpec where
 
 import           ActionSpec                              (itInThread)
 import           Control.Exception                       (SomeException, throw)
-import           Development.IDE.Graph                   (newKey, shakeOptions)
+import           Development.IDE.Graph                   (ShakeOptions, newKey,
+                                                          shakeOptions)
 import           Development.IDE.Graph.Database          (shakeNewDatabase,
                                                           shakeRunDatabase)
 import           Development.IDE.Graph.Internal.Action   (apply1)
@@ -21,12 +22,14 @@ exractException [] = Nothing
 exractException (Left e : _) | Just ne@StackException{} <- fromGraphException e = return ne
 exractException (_: xs) = exractException xs
 
+shakeNewDatabaseWithLogger :: DBQue -> ShakeOptions -> Rules () -> IO ShakeDatabase
+shakeNewDatabaseWithLogger = shakeNewDatabase (const $ return ())
 
 spec :: Spec
 spec = do
     describe "Evaluation" $ do
         itInThread "detects cycles" $ \q -> do
-            db <- shakeNewDatabase q shakeOptions $ do
+            db <- shakeNewDatabaseWithLogger q shakeOptions $ do
                 ruleBool
                 addRule $ \Rule _old _mode -> do
                     True <- apply1 (Rule @Bool)
@@ -40,7 +43,7 @@ spec = do
 
     describe "compute" $ do
       itInThread "build step and changed step updated correctly" $ \q -> do
-        (ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do
+        (ShakeDatabase _ _ theDb) <- shakeNewDatabaseWithLogger q shakeOptions $ do
           ruleStep
         let k = newKey $ Rule @()
         -- ChangedRecomputeSame