Skip to content

Commit dec47a3

Browse files
ndmitchellberberman
ndmitchell
and
berberman
authored
Wrap the Shake functions with newtypes (#1753)
* Add a function addRule, which abstracts over addBuiltinRule * Newtype wrap the Action, Rules and ShakeOption types * Replace addShakeExtra with newShakeExtra * Move the internals of hls-graph around a bit * Expose shakeTimings and shakeAllowRedefineRules through ShakeOptions Co-authored-by: Potato Hatsue <[email protected]>
1 parent dc42129 commit dec47a3

File tree

17 files changed

+148
-15
lines changed

17 files changed

+148
-15
lines changed

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -508,7 +508,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
508508
pure (ShakeExtras{..}, cancel progressAsync)
509509
(shakeDbM, shakeClose) <-
510510
shakeOpenDatabase
511-
opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts }
511+
opts { shakeExtra = newShakeExtra shakeExtras }
512512
rules
513513
shakeDb <- shakeDbM
514514
initSession <- newSession shakeExtras shakeDb []
@@ -932,9 +932,9 @@ defineEarlyCutoff
932932
:: IdeRule k v
933933
=> RuleBody k v
934934
-> Rules ()
935-
defineEarlyCutoff (Rule op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
935+
defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
936936
defineEarlyCutoff' True key file old mode $ op key file
937-
defineEarlyCutoff (RuleNoDiagnostics op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
937+
defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
938938
defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file
939939

940940
defineEarlyCutoff'
@@ -1045,7 +1045,7 @@ defineOnDisk
10451045
:: (Shake.ShakeValue k, RuleResult k ~ ())
10461046
=> (k -> NormalizedFilePath -> OnDiskRule)
10471047
-> Rules ()
1048-
defineOnDisk act = addBuiltinRule noLint noIdentity $
1048+
defineOnDisk act = addRule $
10491049
\(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do
10501050
extras <- getShakeExtras
10511051
let OnDiskRule{..} = act key file

‎hls-graph/hls-graph.cabal‎

Lines changed: 8 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -31,10 +31,17 @@ library
3131
Development.IDE.Graph.Database
3232
Development.IDE.Graph.Rule
3333

34+
other-modules:
35+
Development.IDE.Graph.Internal.Action
36+
Development.IDE.Graph.Internal.Options
37+
Development.IDE.Graph.Internal.Rules
38+
3439
hs-source-dirs: src
3540
build-depends:
3641
, base >=4.12 && <5
37-
, shake >= 0.18.4
42+
, bytestring
43+
, shake >= 0.19.4
44+
, unordered-containers
3845

3946
ghc-options:
4047
-Wall -Wredundant-constraints -Wno-name-shadowing

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

Lines changed: 7 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -5,18 +5,21 @@ module Development.IDE.Graph(
55
Rules,
66
Action, action,
77
actionFinally, actionBracket, actionCatch,
8-
ShakeException(..),
8+
Shake.ShakeException(..),
99
-- * Configuration
1010
ShakeOptions(shakeThreads, shakeFiles, shakeExtra),
11-
getShakeExtra, getShakeExtraRules, addShakeExtra,
11+
getShakeExtra, getShakeExtraRules, newShakeExtra,
1212
-- * Explicit parallelism
1313
parallel,
1414
-- * Oracle rules
15-
ShakeValue, RuleResult,
15+
Shake.ShakeValue, Shake.RuleResult,
1616
-- * Special rules
1717
alwaysRerun,
1818
-- * Batching
1919
reschedule,
2020
) where
2121

22-
import Development.Shake
22+
import qualified Development.Shake as Shake
23+
import Development.IDE.Graph.Internal.Action
24+
import Development.IDE.Graph.Internal.Options
25+
import Development.IDE.Graph.Internal.Rules

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

Lines changed: 12 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,18 @@
11

22
module Development.IDE.Graph.Database(
3-
ShakeDatabase,
3+
Shake.ShakeDatabase,
44
shakeOpenDatabase,
55
shakeRunDatabase,
6-
shakeProfileDatabase,
6+
Shake.shakeProfileDatabase,
77
) where
88

9-
import Development.Shake.Database
9+
import qualified Development.Shake.Database as Shake
10+
import Development.IDE.Graph.Internal.Action
11+
import Development.IDE.Graph.Internal.Options
12+
import Development.IDE.Graph.Internal.Rules
13+
14+
shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO Shake.ShakeDatabase, IO ())
15+
shakeOpenDatabase a b = Shake.shakeOpenDatabase (fromShakeOptions a) (fromRules b)
16+
17+
shakeRunDatabase :: Shake.ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
18+
shakeRunDatabase a b = Shake.shakeRunDatabase a (map fromAction b)

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

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,38 @@
1+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
{-# LANGUAGE TypeFamilies #-}
3+
4+
module Development.IDE.Graph.Internal.Action where
5+
6+
import qualified Development.Shake as Shake
7+
import qualified Development.Shake.Rule as Shake
8+
import Development.Shake.Classes
9+
import Control.Exception
10+
import Control.Monad.IO.Class
11+
import Control.Monad.Fail
12+
13+
newtype Action a = Action {fromAction :: Shake.Action a}
14+
deriving (Monad, Applicative, Functor, MonadIO, MonadFail)
15+
16+
alwaysRerun :: Action ()
17+
alwaysRerun = Action Shake.alwaysRerun
18+
19+
reschedule :: Double -> Action ()
20+
reschedule = Action . Shake.reschedule
21+
22+
parallel :: [Action a] -> Action [a]
23+
parallel = Action . Shake.parallel . map fromAction
24+
25+
actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
26+
actionCatch a b = Action $ Shake.actionCatch (fromAction a) (fromAction . b)
27+
28+
actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
29+
actionBracket a b c = Action $ Shake.actionBracket a b (fromAction . c)
30+
31+
actionFinally :: Action a -> IO b -> Action a
32+
actionFinally a b = Action $ Shake.actionFinally (fromAction a) b
33+
34+
apply1 :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => key -> Action value
35+
apply1 = Action . Shake.apply1
36+
37+
apply :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => [key] -> Action [value]
38+
apply = Action . Shake.apply

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

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
3+
module Development.IDE.Graph.Internal.Options where
4+
5+
import qualified Development.Shake as Shake
6+
import qualified Data.HashMap.Strict as Map
7+
import Development.IDE.Graph.Internal.Action
8+
import Development.IDE.Graph.Internal.Rules
9+
import Data.Dynamic
10+
11+
data ShakeOptions = ShakeOptions {
12+
shakeThreads :: Int,
13+
shakeFiles :: FilePath,
14+
shakeExtra :: Maybe Dynamic,
15+
shakeAllowRedefineRules :: Bool,
16+
shakeTimings :: Bool
17+
}
18+
19+
shakeOptions :: ShakeOptions
20+
shakeOptions = ShakeOptions 0 ".shake" Nothing False False
21+
22+
fromShakeOptions :: ShakeOptions -> Shake.ShakeOptions
23+
fromShakeOptions ShakeOptions{..} = Shake.shakeOptions{
24+
Shake.shakeThreads = shakeThreads,
25+
Shake.shakeFiles = shakeFiles,
26+
Shake.shakeExtra = maybe Map.empty f shakeExtra,
27+
Shake.shakeAllowRedefineRules = shakeAllowRedefineRules,
28+
Shake.shakeTimings = shakeTimings
29+
}
30+
where f x = Map.singleton (dynTypeRep x) x
31+
32+
33+
getShakeExtra :: Typeable a => Action (Maybe a)
34+
getShakeExtra = Action Shake.getShakeExtra
35+
36+
getShakeExtraRules :: Typeable a => Rules (Maybe a)
37+
getShakeExtraRules = Rules Shake.getShakeExtraRules
38+
39+
newShakeExtra :: Typeable a => a -> Maybe Dynamic
40+
newShakeExtra = Just . toDyn

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

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
{-# LANGUAGE TypeFamilies #-}
3+
4+
module Development.IDE.Graph.Internal.Rules where
5+
6+
import qualified Development.Shake as Shake
7+
import qualified Development.Shake.Rule as Shake
8+
import Development.Shake.Classes
9+
import Development.IDE.Graph.Internal.Action
10+
import Control.Monad.IO.Class
11+
import Control.Monad.Fail
12+
import qualified Data.ByteString as BS
13+
14+
newtype Rules a = Rules {fromRules :: Shake.Rules a}
15+
deriving (Monoid, Semigroup, Monad, Applicative, Functor, MonadIO, MonadFail)
16+
17+
action :: Action a -> Rules ()
18+
action = Rules . Shake.action . fromAction
19+
20+
addRule
21+
:: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value, NFData value, Show value)
22+
=> (key -> Maybe BS.ByteString -> Shake.RunMode -> Action (Shake.RunResult value))
23+
-> Rules ()
24+
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‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,15 @@
1+
{-# LANGUAGE TypeFamilies #-}
12

23
module Development.IDE.Graph.Rule(
34
-- * Defining builtin rules
45
-- | Functions and types for defining new types of Shake rules.
5-
addBuiltinRule,
6-
BuiltinLint, noLint, BuiltinIdentity, noIdentity, BuiltinRun, RunMode(..), RunChanged(..), RunResult(..),
6+
addRule,
7+
Shake.RunMode(..), Shake.RunChanged(..), Shake.RunResult(..),
78
-- * Calling builtin rules
89
-- | Wrappers around calling Shake rules. In general these should be specialised to a builtin rule.
910
apply, apply1,
1011
) where
1112

12-
import Development.Shake.Rule
13+
import qualified Development.Shake.Rule as Shake
14+
import Development.IDE.Graph.Internal.Action
15+
import Development.IDE.Graph.Internal.Rules

‎stack-8.10.2.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ extra-deps:
4343
- monad-dijkstra-0.1.1.2
4444
- refinery-0.3.0.0
4545
- retrie-0.1.1.1
46+
- shake-0.19.4
4647
- stylish-haskell-0.12.2.0
4748
- semigroups-0.18.5
4849
- temporary-1.2.1.1

‎stack-8.10.3.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ extra-deps:
3838
- monad-dijkstra-0.1.1.2
3939
- refinery-0.3.0.0
4040
- retrie-0.1.1.1
41+
- shake-0.19.4
4142
- stylish-haskell-0.12.2.0
4243
- semigroups-0.18.5
4344
- temporary-1.2.1.1

0 commit comments

Comments
 (0)