Remove some partial functions from Shake.hs (#2986)

Also removes a partial pattern match from Action.hs.

Author: michaelpj

.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

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
@@ -999,37 +1000,37 @@ useNoFile :: IdeRule k v => k -> Action (Maybe v)
 useNoFile key = use key emptyFilePath
 
 use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
-use_ key file = head <$> uses_ key [file]
+use_ key file = runIdentity <$> uses_ key (Identity file)
 
 useNoFile_ :: IdeRule k v => k -> Action v
 useNoFile_ key = use_ key emptyFilePath
 
-uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
+uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v)
 uses_ key files = do
     res <- uses key files
     case sequence res of
         Nothing -> liftIO $ throwIO $ BadDependency (show key)
         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))

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

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

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

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"