hls-graph 1.7.0.0 → 1.8.0.0

raw patch · 11 files changed

+86/−65 lines, 11 filesdep +unliftioPVP ok

version bump matches the API change (PVP)

Dependencies added: unliftio

API changes (from Hackage documentation)

Files

• hls-graph.cabal +4/−2
• src/Development/IDE/Graph/Database.hs +6/−0
• src/Development/IDE/Graph/Internal/Action.hs +6/−4
• src/Development/IDE/Graph/Internal/Database.hs +19/−11
• src/Development/IDE/Graph/Internal/Rules.hs +1/−1
• src/Development/IDE/Graph/Internal/Types.hs +5/−4
• test/ActionSpec.hs +16/−15
• test/DatabaseSpec.hs +15/−14
• test/Example.hs +10/−10
• test/Main.hs +3/−3
• test/RulesSpec.hs +1/−1

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          hls-graph-version:       1.7.0.0+version:       1.8.0.0 synopsis:      Haskell Language Server internal graph API description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/hls-graph#readme>@@ -61,7 +61,7 @@   hs-source-dirs:     src   build-depends:     , aeson-    , async+    , async >= 2.0     , base >=4.12 && <5     , bytestring     , containers@@ -81,6 +81,7 @@     , stm-containers     , time     , transformers+    , unliftio     , unordered-containers    if flag(embed-files)@@ -133,4 +134,5 @@     , tasty-hunit     , tasty-rerun     , text+    , unordered-containers   build-tool-depends: hspec-discover:hspec-discover -any

@@ -9,6 +9,7 @@     shakeRunDatabaseForKeys,     shakeProfileDatabase,     shakeGetBuildStep,+    shakeGetDatabaseKeys,     shakeGetDirtySet,     shakeGetCleanKeys     ,shakeGetBuildEdges) where@@ -79,3 +80,8 @@     keys <- getDatabaseValues db     let ress = mapMaybe (getResult . snd) keys     return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress++-- | Returns an approximation of the database keys,+--   annotated with how long ago (in # builds) they were visited+shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)]+shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db

@@ -24,6 +24,8 @@ import           Control.Monad.IO.Class import           Control.Monad.Trans.Class import           Control.Monad.Trans.Reader+import           Data.Foldable                           (toList)+import           Data.Functor.Identity import           Data.IORef import           Development.IDE.Graph.Classes import           Development.IDE.Graph.Internal.Database@@ -111,19 +113,19 @@     Action $ lift $ finally (runReaderT (fromAction a) v) b  apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value-apply1 k = head <$> apply [k]+apply1 k = runIdentity <$> apply (Identity k) -apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]+apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value) apply ks = do     db <- Action $ asks actionDatabase     stack <- Action $ asks actionStack     (is, vs) <- liftIO $ build db stack ks     ref <- Action $ asks actionDeps-    liftIO $ modifyIORef ref (ResultDeps is <>)+    liftIO $ modifyIORef ref (ResultDeps (toList is) <>)     pure vs  -- | Evaluate a list of keys without recording any dependencies.-applyWithoutDependency :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]+applyWithoutDependency :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value) applyWithoutDependency ks = do     db <- Action $ asks actionDatabase     stack <- Action $ asks actionStack

@@ -7,11 +7,13 @@ {-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TupleSections #-}  module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where +import           Prelude                              hiding (unzip)+ import           Control.Concurrent.Async import           Control.Concurrent.Extra import           Control.Concurrent.STM.Stats         (STM, atomically,@@ -30,19 +32,21 @@ import           Data.HashSet                         (HashSet) import qualified Data.HashSet                         as HSet import           Data.IORef.Extra+import           Data.List.NonEmpty                   (unzip) import           Data.Maybe import           Data.Traversable                     (for) import           Data.Tuple.Extra-import           Debug.Trace (traceM)+import           Debug.Trace                          (traceM) import           Development.IDE.Graph.Classes import           Development.IDE.Graph.Internal.Rules import           Development.IDE.Graph.Internal.Types import qualified Focus import qualified ListT import qualified StmContainers.Map                    as SMap-import           System.Time.Extra                    (duration, sleep) import           System.IO.Unsafe+import           System.Time.Extra                    (duration, sleep) + newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do     databaseStep <- newTVarIO $ Step 0@@ -78,13 +82,17 @@             in KeyDetails status' rdeps -- | Unwrap and build a list of keys in parallel build-    :: forall key value . (RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)-    => Database -> Stack -> [key] -> IO ([Key], [value])+    :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)+    => Database -> Stack -> f key -> IO (f Key, f value) -- build _ st k | traceShow ("build", st, k) False = undefined build db stack keys = do-    (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<<-            builder db stack (map Key keys)-    pure (ids, map (asV . resultValue) vs)+    built <- runAIO $ do+        built <- builder db stack (fmap Key keys)+        case built of+          Left clean  -> return clean+          Right dirty -> liftIO dirty+    let (ids, vs) = unzip built+    pure (ids, fmap (asV . resultValue) vs)     where         asV :: Value -> value         asV (Value x) = unwrapDynamic x@@ -93,7 +101,7 @@ --  If none of the keys are dirty, we can return the results immediately. --  Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. builder-    :: Database -> Stack -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)]))+    :: Traversable f => Database -> Stack -> f Key -> AIO (Either (f (Key, Result)) (IO (f (Key, Result)))) -- builder _ st kk | traceShow ("builder", st,kk) False = undefined builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do     -- Things that I need to force before my results are ready@@ -199,7 +207,7 @@         calcAgeStatus _         = Nothing     return $ mapMaybe (secondM calcAgeStatus) dbContents --- | Returns ann approximation of the database keys,+-- | Returns an approximation of the database keys, --   annotated with how long ago (in # builds) they were visited getKeysAndVisitAge :: Database -> IO [(Key, Int)] getKeysAndVisitAge db = do@@ -317,7 +325,7 @@     | Spawn {justWait :: !(IO ())}  fmapWait :: (IO () -> IO ()) -> Wait -> Wait-fmapWait f (Wait io) = Wait (f io)+fmapWait f (Wait io)  = Wait (f io) fmapWait f (Spawn io) = Spawn (f io)  waitOrSpawn :: Wait -> IO (Either (IO ()) (Async ()))

@@ -46,7 +46,7 @@ runRule     :: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value) runRule rules key@(Key t) bs mode = case Map.lookup (typeOf t) rules of-    Nothing -> liftIO $ errorIO "Could not find key"+    Nothing -> liftIO $ errorIO $ "Could not find key: " ++ show key     Just x  -> unwrapDynamic x key bs mode  runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])

@@ -27,17 +27,18 @@ import           Data.Dynamic import qualified Data.HashMap.Strict           as Map import           Data.HashSet                  (HashSet, member)+import qualified Data.HashSet                  as Set import           Data.IORef+import           Data.List                     (intercalate) import           Data.Maybe import           Data.Typeable import           Development.IDE.Graph.Classes import           GHC.Generics                  (Generic) import qualified ListT-import           StmContainers.Map             (Map) import qualified StmContainers.Map             as SMap+import           StmContainers.Map             (Map) import           System.Time.Extra             (Seconds)-import qualified Data.HashSet as Set-import Data.List (intercalate)+import           UnliftIO                      (MonadUnliftIO)   unwrapDynamic :: forall a . Typeable a => Dynamic -> a@@ -64,7 +65,7 @@ -- ACTIONS  newtype Action a = Action {fromAction :: ReaderT SAction IO a}-    deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)+    deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)  data SAction = SAction {     actionDatabase :: !Database,

@@ -1,21 +1,22 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}  module ActionSpec where -import Control.Concurrent.STM-import Development.IDE.Graph (shakeOptions)-import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase)-import Development.IDE.Graph.Internal.Action (apply1)-import Development.IDE.Graph.Internal.Types-import Development.IDE.Graph.Rule-import Example-import qualified StmContainers.Map as STM-import Test.Hspec-import System.Time.Extra (timeout)+import           Control.Concurrent.STM+import qualified Data.HashSet                          as HashSet+import           Development.IDE.Graph                 (shakeOptions)+import           Development.IDE.Graph.Database        (shakeNewDatabase,+                                                        shakeRunDatabase)+import           Development.IDE.Graph.Internal.Action (apply1)+import           Development.IDE.Graph.Internal.Types+import           Development.IDE.Graph.Rule+import           Example+import qualified StmContainers.Map                     as STM+import           System.Time.Extra                     (timeout)+import           Test.Hspec  spec :: Spec spec = do@@ -54,7 +55,7 @@           apply1 theKey       res `shouldBe` [True]       Just KeyDetails {..} <- atomically $ STM.lookup (Key (Rule @())) databaseValues-      keyReverseDeps `shouldBe` [Key theKey]+      keyReverseDeps `shouldBe` HashSet.fromList [Key theKey]     it "rethrows exceptions" $ do       db <- shakeNewDatabase shakeOptions $ do         addRule $ \(Rule :: Rule ()) old mode -> error "boom"

@@ -1,20 +1,21 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} module DatabaseSpec where -import Control.Concurrent.STM-import Development.IDE.Graph (shakeOptions)-import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase)-import Development.IDE.Graph.Internal.Action (apply1)-import Development.IDE.Graph.Internal.Types-import Development.IDE.Graph.Rule-import Example-import qualified StmContainers.Map as STM-import Test.Hspec-import System.Time.Extra (timeout)+import           Control.Concurrent.STM+import           Development.IDE.Graph                 (shakeOptions)+import           Development.IDE.Graph.Database        (shakeNewDatabase,+                                                        shakeRunDatabase)+import           Development.IDE.Graph.Internal.Action (apply1)+import           Development.IDE.Graph.Internal.Types+import           Development.IDE.Graph.Rule+import           Example+import qualified StmContainers.Map                     as STM+import           System.Time.Extra                     (timeout)+import           Test.Hspec  spec :: Spec spec = do

@@ -1,16 +1,16 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-} module Example where -import Development.IDE.Graph-import Development.IDE.Graph.Rule-import Development.IDE.Graph.Classes-import GHC.Generics-import Type.Reflection (typeRep)+import           Development.IDE.Graph+import           Development.IDE.Graph.Classes+import           Development.IDE.Graph.Rule+import           GHC.Generics+import           Type.Reflection               (typeRep)  data Rule a = Rule     deriving (Eq, Generic, Hashable, NFData)

@@ -1,7 +1,7 @@ import qualified Spec-import Test.Tasty-import Test.Tasty.Hspec-import Test.Tasty.Ingredients.Rerun (defaultMainWithRerun)+import           Test.Tasty+import           Test.Tasty.Hspec+import           Test.Tasty.Ingredients.Rerun (defaultMainWithRerun)  main :: IO () main = testSpecs Spec.spec >>= defaultMainWithRerun . testGroup "tactics"

@@ -1,6 +1,6 @@ module RulesSpec where -import Test.Hspec+import           Test.Hspec  spec :: Spec spec = do