From 06535a4214a23ab4c6cd966584527220a0844c13 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Fri, 24 Jun 2022 15:59:04 +0100 Subject: [PATCH] Remove some partial functions from Shake.hs Also removes a partial pattern match from Action.hs. --- .hlint.yaml | 2 -- ghcide/src/Development/IDE/Core/Shake.hs | 25 ++++++++++--------- hls-graph/hls-graph.cabal | 1 + .../Development/IDE/Graph/Internal/Action.hs | 10 +++++--- .../IDE/Graph/Internal/Database.hs | 20 ++++++++++----- hls-graph/test/ActionSpec.hs | 4 +-- 6 files changed, 36 insertions(+), 26 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index e8cf2d97511..f50ea75cc3b 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -88,7 +88,6 @@ within: - Main - Experiments - - Development.IDE.Core.Shake - Development.IDE.Plugin.CodeAction - Development.IDE.Plugin.Completions - Development.IDE.Plugin.CodeAction.ExactPrint @@ -137,7 +136,6 @@ - Wingman.CaseSplit - Wingman.Simplify - - name: Data.Text.head within: - Development.IDE.Plugin.CodeAction diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 740a54cb959..8c7e23370be 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -99,6 +99,7 @@ import Data.EnumMap.Strict (EnumMap) import qualified Data.EnumMap.Strict as EM import Data.Foldable (for_, toList) import Data.Functor ((<&>)) +import Data.Functor.Identity import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) @@ -920,21 +921,21 @@ defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics -- | Request a Rule result if available use :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe v) -use key file = head <$> uses key [file] +use key file = runIdentity <$> uses key (Identity file) -- | Request a Rule result, it not available return the last computed result, if any, which may be stale useWithStale :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) -useWithStale key file = head <$> usesWithStale key [file] +useWithStale key file = runIdentity <$> usesWithStale key (Identity file) -- | Request a Rule result, it not available return the last computed result which may be stale. -- Errors out if none available. useWithStale_ :: IdeRule k v => k -> NormalizedFilePath -> Action (v, PositionMapping) -useWithStale_ key file = head <$> usesWithStale_ key [file] +useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) -- | Plural version of 'useWithStale_' -usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)] +usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) usesWithStale_ key files = do res <- usesWithStale key files case sequence res of @@ -1012,24 +1013,24 @@ uses_ key files = do Just v -> return v -- | Plural version of 'use' -uses :: IdeRule k v - => k -> [NormalizedFilePath] -> Action [Maybe v] -uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files) +uses :: (Traversable f, IdeRule k v) + => k -> f NormalizedFilePath -> Action (f (Maybe v)) +uses key files = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q . (key,)) files) -- | Return the last computed result which might be stale. -usesWithStale :: IdeRule k v - => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)] +usesWithStale :: (Traversable f, IdeRule k v) + => k -> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping))) usesWithStale key files = do - _ <- apply (map (Q . (key,)) files) + _ <- apply (fmap (Q . (key,)) files) -- We don't look at the result of the 'apply' since 'lastValue' will -- return the most recent successfully computed value regardless of -- whether the rule succeeded or not. - mapM (lastValue key) files + traverse (lastValue key) files useWithoutDependency :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe v) useWithoutDependency key file = - (\[A value] -> currentValue value) <$> applyWithoutDependency [Q (key, file)] + (\(Identity (A value)) -> currentValue value) <$> applyWithoutDependency (Identity (Q (key, file))) data RuleBody k v = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index bef6f58d323..2edcbe3aa53 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -134,4 +134,5 @@ test-suite tests , tasty-hunit , tasty-rerun , text + , unordered-containers build-tool-depends: hspec-discover:hspec-discover -any diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index b9e9a1b08f9..854ba903c52 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -25,6 +25,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.IORef +import Data.Functor.Identity +import Data.Foldable (toList) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Database import Development.IDE.Graph.Internal.Rules (RuleResult) @@ -111,19 +113,19 @@ actionFinally a b = do 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 diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 0ed2ccbb64f..308bbde232f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -12,6 +12,8 @@ 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,6 +32,7 @@ import Data.Foldable (for_, traverse_) 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 @@ -43,6 +46,7 @@ import qualified StmContainers.Map as SMap import System.Time.Extra (duration, sleep) import System.IO.Unsafe + newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do databaseStep <- newTVarIO $ Step 0 @@ -78,13 +82,17 @@ updateDirty = Focus.adjust $ \(KeyDetails status rdeps) -> 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 @@ build db stack keys = do -- 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 diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 952b6df2416..972786dcc22 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} @@ -12,6 +11,7 @@ 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 qualified Data.HashSet as HashSet import Example import qualified StmContainers.Map as STM import Test.Hspec @@ -54,7 +54,7 @@ spec = do 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"