Wrap the Shake functions with newtypes

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

@@ -508,7 +508,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
         pure (ShakeExtras{..}, cancel progressAsync)
     (shakeDbM, shakeClose) <-
         shakeOpenDatabase
-            opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts }
+            opts { shakeExtra = newShakeExtra shakeExtras }
             rules
     shakeDb <- shakeDbM
     initSession <- newSession shakeExtras shakeDb []
@@ -932,9 +932,9 @@ defineEarlyCutoff
     :: IdeRule k v
     => RuleBody k v
     -> Rules ()
-defineEarlyCutoff (Rule op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
+defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
     defineEarlyCutoff' True key file old mode $ op key file
-defineEarlyCutoff (RuleNoDiagnostics op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
+defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
     defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file
 
 defineEarlyCutoff'
@@ -1045,7 +1045,7 @@ defineOnDisk
   :: (Shake.ShakeValue k, RuleResult k ~ ())
   => (k -> NormalizedFilePath -> OnDiskRule)
   -> Rules ()
-defineOnDisk act = addBuiltinRule noLint noIdentity $
+defineOnDisk act = addRule $
   \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do
       extras <- getShakeExtras
       let OnDiskRule{..} = act key file

hls-graph/hls-graph.cabal

@@ -31,10 +31,17 @@ library
     Development.IDE.Graph.Database
     Development.IDE.Graph.Rule
 
+  other-modules:
+    Development.IDE.Graph.Internal.Action
+    Development.IDE.Graph.Internal.Options
+    Development.IDE.Graph.Internal.Rules
+
   hs-source-dirs:     src
   build-depends:
     , base >=4.12 && <5
-    , shake >= 0.18.4
+    , bytestring
+    , shake >= 0.19.4
+    , unordered-containers
 
   ghc-options:
     -Wall -Wredundant-constraints -Wno-name-shadowing

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

@@ -5,18 +5,21 @@ module Development.IDE.Graph(
     Rules,
     Action, action,
     actionFinally, actionBracket, actionCatch,
-    ShakeException(..),
+    Shake.ShakeException(..),
     -- * Configuration
     ShakeOptions(shakeThreads, shakeFiles, shakeExtra),
-    getShakeExtra, getShakeExtraRules, addShakeExtra,
+    getShakeExtra, getShakeExtraRules, newShakeExtra,
     -- * Explicit parallelism
     parallel,
     -- * Oracle rules
-    ShakeValue, RuleResult,
+    Shake.ShakeValue, Shake.RuleResult,
     -- * Special rules
     alwaysRerun,
     -- * Batching
     reschedule,
     ) where
 
-import Development.Shake
+import qualified Development.Shake as Shake
+import Development.IDE.Graph.Internal.Action
+import Development.IDE.Graph.Internal.Options
+import Development.IDE.Graph.Internal.Rules

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

@@ -1,9 +1,18 @@
 
 module Development.IDE.Graph.Database(
-    ShakeDatabase,
+    Shake.ShakeDatabase,
     shakeOpenDatabase,
     shakeRunDatabase,
-    shakeProfileDatabase,
+    Shake.shakeProfileDatabase,
     ) where
 
-import Development.Shake.Database
+import qualified Development.Shake.Database as Shake
+import Development.IDE.Graph.Internal.Action
+import Development.IDE.Graph.Internal.Options
+import Development.IDE.Graph.Internal.Rules
+
+shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO Shake.ShakeDatabase, IO ())
+shakeOpenDatabase a b = Shake.shakeOpenDatabase (fromShakeOptions a) (fromRules b)
+
+shakeRunDatabase :: Shake.ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
+shakeRunDatabase a b = Shake.shakeRunDatabase a (map fromAction b)

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

@@ -0,0 +1,38 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Development.IDE.Graph.Internal.Action where
+
+import qualified Development.Shake as Shake
+import qualified Development.Shake.Rule as Shake
+import Development.Shake.Classes
+import Control.Exception
+import Control.Monad.IO.Class
+import Control.Monad.Fail
+
+newtype Action a = Action {fromAction :: Shake.Action a}
+    deriving (Monad, Applicative, Functor, MonadIO, MonadFail)
+
+alwaysRerun :: Action ()
+alwaysRerun = Action Shake.alwaysRerun
+
+reschedule :: Double -> Action ()
+reschedule = Action . Shake.reschedule
+
+parallel :: [Action a] -> Action [a]
+parallel = Action . Shake.parallel . map fromAction
+
+actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
+actionCatch a b = Action $ Shake.actionCatch (fromAction a) (fromAction . b)
+
+actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
+actionBracket a b c = Action $ Shake.actionBracket a b (fromAction . c)
+
+actionFinally :: Action a -> IO b -> Action a
+actionFinally a b = Action $ Shake.actionFinally (fromAction a) b
+
+apply1 :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => key -> Action value
+apply1 = Action . Shake.apply1
+
+apply :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => [key] -> Action [value]
+apply = Action . Shake.apply

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

@@ -0,0 +1,40 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Development.IDE.Graph.Internal.Options where
+
+import qualified Development.Shake as Shake
+import qualified Data.HashMap.Strict as Map
+import Development.IDE.Graph.Internal.Action
+import Development.IDE.Graph.Internal.Rules
+import Data.Dynamic
+
+data ShakeOptions = ShakeOptions {
+    shakeThreads :: Int,
+    shakeFiles :: FilePath,
+    shakeExtra :: Maybe Dynamic,
+    shakeAllowRedefineRules :: Bool,
+    shakeTimings :: Bool
+    }
+
+shakeOptions :: ShakeOptions
+shakeOptions = ShakeOptions 0 ".shake" Nothing False False
+
+fromShakeOptions :: ShakeOptions -> Shake.ShakeOptions
+fromShakeOptions ShakeOptions{..} = Shake.shakeOptions{
+    Shake.shakeThreads = shakeThreads,
+    Shake.shakeFiles = shakeFiles,
+    Shake.shakeExtra = maybe Map.empty f shakeExtra,
+    Shake.shakeAllowRedefineRules = shakeAllowRedefineRules,
+    Shake.shakeTimings = shakeTimings
+    }
+    where f x = Map.singleton (dynTypeRep x) x
+
+
+getShakeExtra :: Typeable a => Action (Maybe a)
+getShakeExtra = Action Shake.getShakeExtra
+
+getShakeExtraRules :: Typeable a => Rules (Maybe a)
+getShakeExtraRules = Rules Shake.getShakeExtraRules
+
+newShakeExtra :: Typeable a => a -> Maybe Dynamic
+newShakeExtra = Just . toDyn

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

@@ -0,0 +1,24 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Development.IDE.Graph.Internal.Rules where
+
+import qualified Development.Shake as Shake
+import qualified Development.Shake.Rule as Shake
+import Development.Shake.Classes
+import Development.IDE.Graph.Internal.Action
+import Control.Monad.IO.Class
+import Control.Monad.Fail
+import qualified Data.ByteString as BS
+
+newtype Rules a = Rules {fromRules :: Shake.Rules a}
+    deriving (Monoid, Semigroup, Monad, Applicative, Functor, MonadIO, MonadFail)
+
+action :: Action a -> Rules ()
+action = Rules . Shake.action . fromAction
+
+addRule
+    :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value, NFData value, Show value)
+    => (key -> Maybe BS.ByteString -> Shake.RunMode -> Action (Shake.RunResult value))
+    -> Rules ()
+addRule f = Rules $ Shake.addBuiltinRule Shake.noLint Shake.noIdentity $ \k bs r -> fromAction $ f k bs r

hls-graph/src/Development/IDE/Graph/Rule.hs

@@ -1,12 +1,15 @@
+{-# LANGUAGE TypeFamilies #-}
 
 module Development.IDE.Graph.Rule(
     -- * Defining builtin rules
     -- | Functions and types for defining new types of Shake rules.
-    addBuiltinRule,
-    BuiltinLint, noLint, BuiltinIdentity, noIdentity, BuiltinRun, RunMode(..), RunChanged(..), RunResult(..),
+    addRule,
+    Shake.RunMode(..), Shake.RunChanged(..), Shake.RunResult(..),
     -- * Calling builtin rules
     -- | Wrappers around calling Shake rules. In general these should be specialised to a builtin rule.
     apply, apply1,
     ) where
 
-import Development.Shake.Rule
+import qualified Development.Shake.Rule as Shake
+import Development.IDE.Graph.Internal.Action
+import Development.IDE.Graph.Internal.Rules

stack-8.10.2.yaml

@@ -43,6 +43,7 @@ extra-deps:
   - monad-dijkstra-0.1.1.2
   - refinery-0.3.0.0
   - retrie-0.1.1.1
+  - shake-0.19.4
   - stylish-haskell-0.12.2.0
   - semigroups-0.18.5
   - temporary-1.2.1.1

stack-8.10.3.yaml

@@ -38,6 +38,7 @@ extra-deps:
   - monad-dijkstra-0.1.1.2
   - refinery-0.3.0.0
   - retrie-0.1.1.1
+  - shake-0.19.4
   - stylish-haskell-0.12.2.0
   - semigroups-0.18.5
   - temporary-1.2.1.1

stack-8.10.4.yaml

@@ -36,6 +36,7 @@ extra-deps:
   - monad-dijkstra-0.1.1.2
   - refinery-0.3.0.0
   - retrie-0.1.1.1
+  - shake-0.19.4
   - stylish-haskell-0.12.2.0
   - semigroups-0.18.5
   - temporary-1.2.1.1

stack-8.6.4.yaml

@@ -72,6 +72,7 @@ extra-deps:
   - regex-tdfa-1.3.1.0
   - retrie-0.1.1.1
   - semialign-1.1
+  - shake-0.19.4
   - stylish-haskell-0.12.2.0
   - tasty-rerun-1.1.17
   - temporary-1.2.1.1

stack-8.6.5.yaml

@@ -71,6 +71,7 @@ extra-deps:
   - regex-tdfa-1.3.1.0
   - retrie-0.1.1.1
   - semialign-1.1
+  - shake-0.19.4
   - stylish-haskell-0.12.2.0
   - tasty-rerun-1.1.17
   - temporary-1.2.1.1

stack-8.8.2.yaml

@@ -58,6 +58,7 @@ extra-deps:
   - ormolu-0.1.4.1
   - refinery-0.3.0.0
   - retrie-0.1.1.1
+  - shake-0.19.4
   - semigroups-0.18.5
   - stylish-haskell-0.12.2.0
   - temporary-1.2.1.1

stack-8.8.3.yaml

@@ -54,6 +54,7 @@ extra-deps:
   - refinery-0.3.0.0
   - retrie-0.1.1.1
   - semigroups-0.18.5
+  - shake-0.19.4
   - stylish-haskell-0.12.2.0
   - temporary-1.2.1.1
   - uniplate-1.6.13

stack-8.8.4.yaml

@@ -53,6 +53,7 @@ extra-deps:
   - refinery-0.3.0.0
   - retrie-0.1.1.1
   - semigroups-0.18.5
+  - shake-0.19.4
   - stylish-haskell-0.12.2.0
   - temporary-1.2.1.1
   - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727

stack.yaml

@@ -73,6 +73,7 @@ extra-deps:
   - regex-tdfa-1.3.1.0
   - retrie-0.1.1.1
   - semialign-1.1
+  - shake-0.19.4
   - stylish-haskell-0.12.2.0
   - tasty-rerun-1.1.17
   - temporary-1.2.1.1