hls-graph 1.4.0.0 → 1.5.1.0
raw patch · 16 files changed
+2552/−81 lines, 16 filesdep +aesondep +asyncdep +containersdep −shakenew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: aeson, async, containers, deepseq, directory, exceptions, extra, file-embed, filepath, hashable, js-dgtable, js-flot, js-jquery, primitive, template-haskell, time, transformers
Dependencies removed: shake
API changes (from Hackage documentation)
- Development.IDE.Graph: ShakeException :: String -> [String] -> SomeException -> ShakeException
- Development.IDE.Graph: [shakeExceptionInner] :: ShakeException -> SomeException
- Development.IDE.Graph: [shakeExceptionStack] :: ShakeException -> [String]
- Development.IDE.Graph: [shakeExceptionTarget] :: ShakeException -> String
- Development.IDE.Graph: data ShakeException
- Development.IDE.Graph.Classes: class Binary t
- Development.IDE.Graph.Classes: get :: Binary t => Get t
- Development.IDE.Graph.Classes: put :: Binary t => t -> Put
- Development.IDE.Graph.Classes: putList :: Binary t => [t] -> Put
- Development.IDE.Graph.Database: SomeShakeValue :: k -> SomeShakeValue
- Development.IDE.Graph.Database: data SomeShakeValue
- Development.IDE.Graph.Database: instance Data.Hashable.Class.Hashable Development.IDE.Graph.Database.SomeShakeValue
- Development.IDE.Graph.Database: instance GHC.Classes.Eq Development.IDE.Graph.Database.SomeShakeValue
- Development.IDE.Graph.Database: instance GHC.Show.Show Development.IDE.Graph.Database.SomeShakeValue
+ Development.IDE.Graph: Key :: a -> Key
+ Development.IDE.Graph: actionFork :: Action a -> (Async a -> Action b) -> Action b
+ Development.IDE.Graph: data Key
+ Development.IDE.Graph: getDirtySet :: Action [(Key, Int)]
+ Development.IDE.Graph: getKeysAndVisitedAge :: Action [(Key, Int)]
+ Development.IDE.Graph.Database: shakeGetBuildEdges :: ShakeDatabase -> IO Int
+ Development.IDE.Graph.Database: shakeGetBuildStep :: ShakeDatabase -> IO Int
+ Development.IDE.Graph.Database: shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result)]
+ Development.IDE.Graph.Database: shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)]
+ Development.IDE.Graph.Database: shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
+ Development.IDE.Graph.Database: type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
+ Development.IDE.Graph.Internal.Action: actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
+ Development.IDE.Graph.Internal.Action: actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
+ Development.IDE.Graph.Internal.Action: actionFinally :: Action a -> IO b -> Action a
+ Development.IDE.Graph.Internal.Action: actionFork :: Action a -> (Async a -> Action b) -> Action b
+ Development.IDE.Graph.Internal.Action: alwaysRerun :: Action ()
+ Development.IDE.Graph.Internal.Action: apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]
+ Development.IDE.Graph.Internal.Action: apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
+ Development.IDE.Graph.Internal.Action: getDirtySet :: Action [(Key, Int)]
+ Development.IDE.Graph.Internal.Action: getKeysAndVisitedAge :: Action [(Key, Int)]
+ Development.IDE.Graph.Internal.Action: parallel :: [Action a] -> Action [a]
+ Development.IDE.Graph.Internal.Action: reschedule :: Double -> Action ()
+ Development.IDE.Graph.Internal.Action: runActions :: Database -> [Action a] -> IO [a]
+ Development.IDE.Graph.Internal.Action: type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
+ Development.IDE.Graph.Internal.Database: build :: forall key value. (RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) => Database -> [key] -> IO ([Id], [value])
+ Development.IDE.Graph.Internal.Database: getDirtySet :: Database -> IO [(Id, (Key, Int))]
+ Development.IDE.Graph.Internal.Database: getKeysAndVisitAge :: Database -> IO [(Key, Int)]
+ Development.IDE.Graph.Internal.Database: incDatabase :: Database -> Maybe [Key] -> IO ()
+ Development.IDE.Graph.Internal.Database: instance Control.Monad.IO.Class.MonadIO Development.IDE.Graph.Internal.Database.AIO
+ Development.IDE.Graph.Internal.Database: instance GHC.Base.Applicative Development.IDE.Graph.Internal.Database.AIO
+ Development.IDE.Graph.Internal.Database: instance GHC.Base.Functor Development.IDE.Graph.Internal.Database.AIO
+ Development.IDE.Graph.Internal.Database: instance GHC.Base.Functor Development.IDE.Graph.Internal.Database.Wait
+ Development.IDE.Graph.Internal.Database: instance GHC.Base.Monad Development.IDE.Graph.Internal.Database.AIO
+ Development.IDE.Graph.Internal.Database: newDatabase :: Dynamic -> TheRules -> IO Database
+ Development.IDE.Graph.Internal.Ids: data Ids a
+ Development.IDE.Graph.Internal.Ids: elems :: Ids a -> IO [a]
+ Development.IDE.Graph.Internal.Ids: empty :: IO (Ids a)
+ Development.IDE.Graph.Internal.Ids: forCopy :: Ids a -> (a -> b) -> IO (Ids b)
+ Development.IDE.Graph.Internal.Ids: forMutate :: Ids a -> (Id -> a -> a) -> IO ()
+ Development.IDE.Graph.Internal.Ids: forWithKeyM_ :: Ids a -> (Id -> a -> IO ()) -> IO ()
+ Development.IDE.Graph.Internal.Ids: fromList :: [a] -> IO (Ids a)
+ Development.IDE.Graph.Internal.Ids: insert :: Ids a -> Id -> a -> IO ()
+ Development.IDE.Graph.Internal.Ids: lookup :: Ids a -> Id -> IO (Maybe a)
+ Development.IDE.Graph.Internal.Ids: null :: Ids a -> IO Bool
+ Development.IDE.Graph.Internal.Ids: size :: Ids a -> IO Int
+ Development.IDE.Graph.Internal.Ids: sizeUpperBound :: Ids a -> IO Int
+ Development.IDE.Graph.Internal.Ids: toList :: Ids a -> IO [(Id, a)]
+ Development.IDE.Graph.Internal.Ids: toMap :: Ids a -> IO (HashMap Id a)
+ Development.IDE.Graph.Internal.Ids: type Id = Int
+ Development.IDE.Graph.Internal.Intern: add :: (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)
+ Development.IDE.Graph.Internal.Intern: data Intern a
+ Development.IDE.Graph.Internal.Intern: empty :: Intern a
+ Development.IDE.Graph.Internal.Intern: fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a
+ Development.IDE.Graph.Internal.Intern: insert :: (Eq a, Hashable a) => a -> Id -> Intern a -> Intern a
+ Development.IDE.Graph.Internal.Intern: lookup :: (Eq a, Hashable a) => a -> Intern a -> Maybe Id
+ Development.IDE.Graph.Internal.Intern: toList :: Intern a -> [(a, Id)]
+ Development.IDE.Graph.Internal.Intern: type Id = Int
+ Development.IDE.Graph.Internal.Options: ShakeOptions :: Int -> FilePath -> Maybe Dynamic -> Bool -> Bool -> ShakeOptions
+ Development.IDE.Graph.Internal.Options: [shakeAllowRedefineRules] :: ShakeOptions -> Bool
+ Development.IDE.Graph.Internal.Options: [shakeExtra] :: ShakeOptions -> Maybe Dynamic
+ Development.IDE.Graph.Internal.Options: [shakeFiles] :: ShakeOptions -> FilePath
+ Development.IDE.Graph.Internal.Options: [shakeThreads] :: ShakeOptions -> Int
+ Development.IDE.Graph.Internal.Options: [shakeTimings] :: ShakeOptions -> Bool
+ Development.IDE.Graph.Internal.Options: data ShakeOptions
+ Development.IDE.Graph.Internal.Options: getShakeExtra :: Typeable a => Action (Maybe a)
+ Development.IDE.Graph.Internal.Options: getShakeExtraRules :: Typeable a => Rules (Maybe a)
+ Development.IDE.Graph.Internal.Options: newShakeExtra :: Typeable a => a -> Maybe Dynamic
+ Development.IDE.Graph.Internal.Options: shakeOptions :: ShakeOptions
+ Development.IDE.Graph.Internal.Paths: getDataFile :: FilePath -> IO FilePath
+ Development.IDE.Graph.Internal.Profile: writeProfile :: FilePath -> Database -> IO ()
+ Development.IDE.Graph.Internal.Rules: action :: Action a -> Rules ()
+ Development.IDE.Graph.Internal.Rules: addRule :: forall key value. (RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value) => (key -> Maybe ByteString -> RunMode -> Action (RunResult value)) -> Rules ()
+ Development.IDE.Graph.Internal.Rules: runRule :: TheRules -> Key -> Maybe ByteString -> RunMode -> Action (RunResult Value)
+ Development.IDE.Graph.Internal.Rules: runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])
+ Development.IDE.Graph.Internal.Rules: type family RuleResult key
+ Development.IDE.Graph.Internal.Types: Action :: ReaderT SAction IO a -> Action a
+ Development.IDE.Graph.Internal.Types: AlwaysRerunDeps :: ![Id] -> ResultDeps
+ Development.IDE.Graph.Internal.Types: ChangedNothing :: RunChanged
+ Development.IDE.Graph.Internal.Types: ChangedRecomputeDiff :: RunChanged
+ Development.IDE.Graph.Internal.Types: ChangedRecomputeSame :: RunChanged
+ Development.IDE.Graph.Internal.Types: ChangedStore :: RunChanged
+ Development.IDE.Graph.Internal.Types: Clean :: Result -> Status
+ Development.IDE.Graph.Internal.Types: Database :: Dynamic -> TheRules -> !IORef Step -> !Lock -> !IORef (Intern Key) -> !Ids (Key, Status) -> !Ids IntSet -> !Lock -> Database
+ Development.IDE.Graph.Internal.Types: Dirty :: Maybe Result -> Status
+ Development.IDE.Graph.Internal.Types: Key :: a -> Key
+ Development.IDE.Graph.Internal.Types: Result :: !Value -> !Step -> !Step -> !Step -> !ResultDeps -> !Seconds -> ByteString -> Result
+ Development.IDE.Graph.Internal.Types: ResultDeps :: ![Id] -> ResultDeps
+ Development.IDE.Graph.Internal.Types: Rules :: ReaderT SRules IO a -> Rules a
+ Development.IDE.Graph.Internal.Types: RunDependenciesChanged :: RunMode
+ Development.IDE.Graph.Internal.Types: RunDependenciesSame :: RunMode
+ Development.IDE.Graph.Internal.Types: RunResult :: RunChanged -> ByteString -> value -> RunResult value
+ Development.IDE.Graph.Internal.Types: Running :: IO () -> Result -> Maybe Result -> Status
+ Development.IDE.Graph.Internal.Types: SAction :: !Database -> !IORef ResultDeps -> SAction
+ Development.IDE.Graph.Internal.Types: SRules :: !Dynamic -> !IORef [Action ()] -> !IORef TheRules -> SRules
+ Development.IDE.Graph.Internal.Types: Step :: Int -> Step
+ Development.IDE.Graph.Internal.Types: UnknownDeps :: ResultDeps
+ Development.IDE.Graph.Internal.Types: Value :: Dynamic -> Value
+ Development.IDE.Graph.Internal.Types: [actionDatabase] :: SAction -> !Database
+ Development.IDE.Graph.Internal.Types: [actionDeps] :: SAction -> !IORef ResultDeps
+ Development.IDE.Graph.Internal.Types: [databaseExtra] :: Database -> Dynamic
+ Development.IDE.Graph.Internal.Types: [databaseIds] :: Database -> !IORef (Intern Key)
+ Development.IDE.Graph.Internal.Types: [databaseLock] :: Database -> !Lock
+ Development.IDE.Graph.Internal.Types: [databaseReverseDepsLock] :: Database -> !Lock
+ Development.IDE.Graph.Internal.Types: [databaseReverseDeps] :: Database -> !Ids IntSet
+ Development.IDE.Graph.Internal.Types: [databaseRules] :: Database -> TheRules
+ Development.IDE.Graph.Internal.Types: [databaseStep] :: Database -> !IORef Step
+ Development.IDE.Graph.Internal.Types: [databaseValues] :: Database -> !Ids (Key, Status)
+ Development.IDE.Graph.Internal.Types: [fromAction] :: Action a -> ReaderT SAction IO a
+ Development.IDE.Graph.Internal.Types: [resultBuilt] :: Result -> !Step
+ Development.IDE.Graph.Internal.Types: [resultChanged] :: Result -> !Step
+ Development.IDE.Graph.Internal.Types: [resultData] :: Result -> ByteString
+ Development.IDE.Graph.Internal.Types: [resultDeps] :: Result -> !ResultDeps
+ Development.IDE.Graph.Internal.Types: [resultExecution] :: Result -> !Seconds
+ Development.IDE.Graph.Internal.Types: [resultValue] :: Result -> !Value
+ Development.IDE.Graph.Internal.Types: [resultVisited] :: Result -> !Step
+ Development.IDE.Graph.Internal.Types: [rulesActions] :: SRules -> !IORef [Action ()]
+ Development.IDE.Graph.Internal.Types: [rulesExtra] :: SRules -> !Dynamic
+ Development.IDE.Graph.Internal.Types: [rulesMap] :: SRules -> !IORef TheRules
+ Development.IDE.Graph.Internal.Types: [runChanged] :: RunResult value -> RunChanged
+ Development.IDE.Graph.Internal.Types: [runStore] :: RunResult value -> ByteString
+ Development.IDE.Graph.Internal.Types: [runValue] :: RunResult value -> value
+ Development.IDE.Graph.Internal.Types: data Database
+ Development.IDE.Graph.Internal.Types: data Key
+ Development.IDE.Graph.Internal.Types: data Result
+ Development.IDE.Graph.Internal.Types: data ResultDeps
+ Development.IDE.Graph.Internal.Types: data RunChanged
+ Development.IDE.Graph.Internal.Types: data RunMode
+ Development.IDE.Graph.Internal.Types: data RunResult value
+ Development.IDE.Graph.Internal.Types: data SAction
+ Development.IDE.Graph.Internal.Types: data SRules
+ Development.IDE.Graph.Internal.Types: data Status
+ Development.IDE.Graph.Internal.Types: getDatabase :: Action Database
+ Development.IDE.Graph.Internal.Types: getResult :: Status -> Maybe Result
+ Development.IDE.Graph.Internal.Types: getResultDepsDefault :: [Id] -> ResultDeps -> [Id]
+ Development.IDE.Graph.Internal.Types: instance Control.DeepSeq.NFData Development.IDE.Graph.Internal.Types.RunChanged
+ Development.IDE.Graph.Internal.Types: instance Control.DeepSeq.NFData Development.IDE.Graph.Internal.Types.RunMode
+ Development.IDE.Graph.Internal.Types: instance Control.DeepSeq.NFData value => Control.DeepSeq.NFData (Development.IDE.Graph.Internal.Types.RunResult value)
+ Development.IDE.Graph.Internal.Types: instance Control.Monad.Catch.MonadCatch Development.IDE.Graph.Internal.Types.Action
+ Development.IDE.Graph.Internal.Types: instance Control.Monad.Catch.MonadMask Development.IDE.Graph.Internal.Types.Action
+ Development.IDE.Graph.Internal.Types: instance Control.Monad.Catch.MonadThrow Development.IDE.Graph.Internal.Types.Action
+ Development.IDE.Graph.Internal.Types: instance Control.Monad.Fail.MonadFail Development.IDE.Graph.Internal.Types.Action
+ Development.IDE.Graph.Internal.Types: instance Control.Monad.Fail.MonadFail Development.IDE.Graph.Internal.Types.Rules
+ Development.IDE.Graph.Internal.Types: instance Control.Monad.IO.Class.MonadIO Development.IDE.Graph.Internal.Types.Action
+ Development.IDE.Graph.Internal.Types: instance Control.Monad.IO.Class.MonadIO Development.IDE.Graph.Internal.Types.Rules
+ Development.IDE.Graph.Internal.Types: instance Data.Aeson.Types.FromJSON.FromJSON Development.IDE.Graph.Internal.Types.RunChanged
+ Development.IDE.Graph.Internal.Types: instance Data.Aeson.Types.ToJSON.ToJSON Development.IDE.Graph.Internal.Types.RunChanged
+ Development.IDE.Graph.Internal.Types: instance Data.Hashable.Class.Hashable Development.IDE.Graph.Internal.Types.Key
+ Development.IDE.Graph.Internal.Types: instance Data.Hashable.Class.Hashable Development.IDE.Graph.Internal.Types.Step
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Applicative Development.IDE.Graph.Internal.Types.Action
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Applicative Development.IDE.Graph.Internal.Types.Rules
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Functor Development.IDE.Graph.Internal.Types.Action
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Functor Development.IDE.Graph.Internal.Types.Rules
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Functor Development.IDE.Graph.Internal.Types.RunResult
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Monad Development.IDE.Graph.Internal.Types.Action
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Monad Development.IDE.Graph.Internal.Types.Rules
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Monoid Development.IDE.Graph.Internal.Types.ResultDeps
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Monoid a => GHC.Base.Monoid (Development.IDE.Graph.Internal.Types.Rules a)
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Semigroup Development.IDE.Graph.Internal.Types.ResultDeps
+ Development.IDE.Graph.Internal.Types: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Development.IDE.Graph.Internal.Types.Rules a)
+ Development.IDE.Graph.Internal.Types: instance GHC.Classes.Eq Development.IDE.Graph.Internal.Types.Key
+ Development.IDE.Graph.Internal.Types: instance GHC.Classes.Eq Development.IDE.Graph.Internal.Types.RunChanged
+ Development.IDE.Graph.Internal.Types: instance GHC.Classes.Eq Development.IDE.Graph.Internal.Types.RunMode
+ Development.IDE.Graph.Internal.Types: instance GHC.Classes.Eq Development.IDE.Graph.Internal.Types.Step
+ Development.IDE.Graph.Internal.Types: instance GHC.Classes.Ord Development.IDE.Graph.Internal.Types.Step
+ Development.IDE.Graph.Internal.Types: instance GHC.Generics.Generic Development.IDE.Graph.Internal.Types.RunChanged
+ Development.IDE.Graph.Internal.Types: instance GHC.Show.Show Development.IDE.Graph.Internal.Types.Key
+ Development.IDE.Graph.Internal.Types: instance GHC.Show.Show Development.IDE.Graph.Internal.Types.RunChanged
+ Development.IDE.Graph.Internal.Types: instance GHC.Show.Show Development.IDE.Graph.Internal.Types.RunMode
+ Development.IDE.Graph.Internal.Types: mapResultDeps :: ([Id] -> [Id]) -> ResultDeps -> ResultDeps
+ Development.IDE.Graph.Internal.Types: newtype Action a
+ Development.IDE.Graph.Internal.Types: newtype Rules a
+ Development.IDE.Graph.Internal.Types: newtype Step
+ Development.IDE.Graph.Internal.Types: newtype Value
+ Development.IDE.Graph.Internal.Types: type TheRules = HashMap TypeRep Dynamic
+ Development.IDE.Graph.Internal.Types: unwrapDynamic :: forall a. Typeable a => Dynamic -> a
+ Paths_hls_graph: getBinDir :: IO FilePath
+ Paths_hls_graph: getDataDir :: IO FilePath
+ Paths_hls_graph: getDataFileName :: FilePath -> IO FilePath
+ Paths_hls_graph: getDynLibDir :: IO FilePath
+ Paths_hls_graph: getLibDir :: IO FilePath
+ Paths_hls_graph: getLibexecDir :: IO FilePath
+ Paths_hls_graph: getSysconfDir :: IO FilePath
+ Paths_hls_graph: version :: Version
- Development.IDE.Graph: type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a)
+ Development.IDE.Graph: type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
- Development.IDE.Graph.Classes: class Hashable a
+ Development.IDE.Graph.Classes: class Eq a => Hashable a
- Development.IDE.Graph.Database: shakeRunDatabaseForKeys :: Maybe [SomeShakeValue] -> ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
+ Development.IDE.Graph.Database: shakeRunDatabaseForKeys :: Maybe [Key] -> ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
- Development.IDE.Graph.Rule: addRule :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value) => (key -> Maybe ByteString -> RunMode -> Action (RunResult value)) -> Rules ()
+ Development.IDE.Graph.Rule: addRule :: forall key value. (RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value) => (key -> Maybe ByteString -> RunMode -> Action (RunResult value)) -> Rules ()
Files
- hls-graph.cabal +39/−4
- html/profile.html +211/−0
- html/shake.js +1058/−0
- src/Development/IDE/Graph.hs +8/−4
- src/Development/IDE/Graph/Classes.hs +4/−2
- src/Development/IDE/Graph/Database.hs +71/−21
- src/Development/IDE/Graph/Internal/Action.hs +117/−17
- src/Development/IDE/Graph/Internal/Database.hs +301/−0
- src/Development/IDE/Graph/Internal/Ids.hs +160/−0
- src/Development/IDE/Graph/Internal/Intern.hs +41/−0
- src/Development/IDE/Graph/Internal/Options.hs +9/−17
- src/Development/IDE/Graph/Internal/Paths.hs +71/−0
- src/Development/IDE/Graph/Internal/Profile.hs +226/−0
- src/Development/IDE/Graph/Internal/Rules.hs +50/−14
- src/Development/IDE/Graph/Internal/Types.hs +184/−0
- src/Development/IDE/Graph/Rule.hs +2/−2
hls-graph.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-graph-version: 1.4.0.0+version: 1.5.1.0 synopsis: Haskell Language Server internal graph API description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -14,12 +14,20 @@ copyright: The Haskell IDE Team category: Development build-type: Simple+data-files:+ html/profile.html+ html/shake.js flag pedantic description: Enable -Werror default: False manual: True +flag embed-files+ default: False+ manual: True+ description: Embed data files into the shake library+ source-repository head type: git location: https://github.com/haskell/haskell-language-server@@ -30,18 +38,45 @@ Development.IDE.Graph.Classes 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+ Development.IDE.Graph.Internal.Database+ Development.IDE.Graph.Internal.Ids+ Development.IDE.Graph.Internal.Intern+ Development.IDE.Graph.Internal.Paths+ Development.IDE.Graph.Internal.Profile+ Development.IDE.Graph.Internal.Types+ Paths_hls_graph + autogen-modules: Paths_hls_graph+ hs-source-dirs: src build-depends:+ , aeson+ , async , base >=4.12 && <5 , bytestring- , shake >= 0.19.4+ , containers+ , deepseq+ , directory+ , exceptions+ , extra+ , filepath+ , hashable+ , js-dgtable+ , js-flot+ , js-jquery+ , primitive+ , time+ , transformers , unordered-containers++ if flag(embed-files)+ cpp-options: -DFILE_EMBED+ build-depends:+ file-embed >= 0.0.11,+ template-haskell ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing
+ html/profile.html view
@@ -0,0 +1,211 @@+<!DOCTYPE html>+<html lang="en">+<head>++<meta charset="utf-8" />+<title>Shake report</title>++<!-- Profiling output -->+<script src="data/profile-data.js"></script>+<script src="data/build-data.js"></script>+<script src="data/metadata.js"></script>+<!-- Libraries -->+<script src="lib/jquery.js"></script>+<script src="lib/jquery.flot.js"></script>+<script src="lib/jquery.flot.stack.js"></script>+<script src="lib/jquery.dgtable.js"></script>+<!-- Functions for creating info from Shake builds -->+<script src="shake.js"></script>++<style type="text/css">+body {font-family: sans-serif; font-size: 10pt; background-color: #e8e8e8;}+.data {font-size: 9pt; border-spacing: 0px; border-collapse: collapse;}+.data td {padding-left: 7px; padding-right: 7px;}+.header {font-weight: bold; background-color: #eee !important;}+.header td:hover {background-color: #ccc !important;}+.header td {border: 1px solid #ccc; cursor: pointer;}+.data tr:hover {background-color: #ddd !important; color: black !important;}+* {box-sizing: border-box;}+html, body, .fill {height: 100%; width:100%;}+table.fill {border-spacing: 0px;}+input:focus {border-color: rgb(77, 144, 254) !important; outline-width: 0px !important;}+.note {margin-left: 10px;}+.note, .note a {color: gray;}+a tt {color: #315273;}++.tabstrip a {+ border-radius: 4px 4px 0px 0px;+ border: 1px solid gray;+ padding: 4px 8px;+ box-sizing: border-box;+ cursor: pointer;+ white-space: nowrap;+ user-select: none;+ }+.tabstrip .bottom {+ padding: 4px 8px;+ border-bottom: 1px solid gray;+}+.tabstrip .active {+ border-top: 4px solid orange;+ border-bottom: 3px solid white;+ background-color: white;+}+.right { text-align: right; }+.dropdown {+ border:1px solid gray;+ background-color:white;+ white-space:nowrap;+ position:absolute;+ right:10px;+ padding-right:10px;+ box-shadow: 3px 3px 5px #ccc;+ z-index: 100;+}+.dropdown a tt {+ cursor: pointer;+ color: #1467bb !important;+}+.details a {+ cursor: pointer;+ color: #1467bb;+}++/* My overrides */+/* Make the colors and font size match better */+.dgtable-row:hover { background-color: #e8e8e8 !important; }+.dgtable-header-cell:hover { background-color: #ddd !important; }+.dgtable-header-cell { background-color: #eee !important; }+.dgtable-cell:last-child, .dgtable-header-cell:last-child { border-right: 1px solid #ccc; }++/* Make the header smaller */+.dgtable-header-row, .dgtable-header-cell { height: 22px !important; }+.dgtable-header-cell { padding: 2px 4px !important; }+.dgtable-header-cell, .dgtable-cell-preview.header { font-size: 9pt !important; }++/* Make the rows smaller */+.dgtable-row { height: 22px !important; }+.dgtable-row:first-child { height: 23px !important; }+.dgtable-cell { padding: 2px 4px !important; height: 22px !important; }+.dgtable-cell, .dgtable-cell-preview{ font-size: 9pt !important; }++.dgtable-wrapper * {+ box-sizing: border-box;+}+.dgtable-wrapper {+ border: solid 1px #ccc;+}+.dgtable {+ border-top: solid 1px #ccc;+ max-width: 100%;+ background-color: transparent;+}+.dgtable-header {+ max-width: 100%;+ overflow: hidden;+ background: #eee;+}+.dgtable-header-row {+ height: 26px;+}+.dgtable-header-cell {+ float: left;+ padding: 4px;+ height: 26px;+ border-left: solid 1px #ccc;+ background: #ddd;+ font-size: 13px;+ line-height: 16px;+ font-weight: bold;+ cursor: default;+ text-align: left;+}+.dgtable-header-cell:first-child {+ border-left: 0;+}+.dgtable-header-cell > div {+ border: 1px dashed transparent;+ white-space: nowrap;+ overflow-x: hidden;+ text-overflow: ellipsis;+}+.dgtable-header-cell.drag-over > div {+ border-color: #666;+ background: #bbb;+}+.dgtable-row {+ border-top: solid 1px #ccc;+ height: 28px;+}+.dgtable-row:first-child {+ border-top: 0;+ height: 29px;+}+.dgtable.virtual .dgtable-row {+ border-top: 0;+ border-bottom: solid 1px #ccc;+}+.dgtable-cell {+ float: left;+ padding: 4px 4px 4px;+ height: 28px;+ border-left: solid 1px #ccc;+ font-size: 16px;+ line-height: 19px;+}+.dgtable-cell > div {+ max-height: 100%;+ white-space: nowrap;+ overflow: hidden+}+.dgtable-cell:first-child {+ border-left: 0;+}+.dgtable-header-cell.sortable {+ cursor: pointer;+}+.dgtable-header-cell.sorted .sort-arrow {+ float: right;+ display: inline-block;+ width: 15px;+ height: 6px;+ margin: 5px 0 0 0;+ background: url("data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAsAAAAGCAMAAAAi7JTKAAAAIGNIUk0AAHolAACAgwAA+f8AAIDpAAB1MAAA6mAAADqYAAAXb5JfxUYAAAMAUExURQNOov///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAH52dxwAAAACdFJOU/8A5bcwSgAAAAlwSFlzAAALEwAACxMBAJqcGAAAAB9JREFUCB0FwQEBAAAAgJD8Px0VoFKgRKEIpRBUEAgMBlQAL3y6umEAAAAASUVORK5CYII=") no-repeat center center;+}++.dgtable-header-cell.sorted.desc .sort-arrow {+ background-image: url("data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAsAAAAGCAMAAAAi7JTKAAAAIGNIUk0AAHolAACAgwAA+f8AAIDpAAB1MAAA6mAAADqYAAAXb5JfxUYAAAMAUExURQNOov///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAH52dxwAAAACdFJOU/8A5bcwSgAAAAlwSFlzAAALEwAACxMBAJqcGAAAAB9JREFUCB0FwQEBAAAAgJD8Px2BQFBBKIUoFClQKkANBywAL6PcDsUAAAAASUVORK5CYII=");+}++.dgtable-cell-preview {+ font-size: 16px;+ line-height: 19px;+}++/* Making the cell preview show correct styling when previewing header cells */+.dgtable-cell-preview.header {+ font-size: 13px;+ line-height: 16px;+ font-weight: bold;+ text-align: left;+}++.dgtable-cell-preview.header > div {+ border: 1px dashed transparent;+}++.dgtable-cell-preview.header.sortable {+ cursor: pointer;+}++.dgtable-cell-preview.header.drag-over > div {+ border-color: #666;+ background: #bbb;+}+</style>++</head>+<body style="margin:0px;padding:0px;" onload="profileLoaded(profile, build)">+ Loading...+</body>+</html>
+ html/shake.js view
@@ -0,0 +1,1058 @@+"use strict";+function bindPlot(element, data, options) {+ const redraw = () => {+ if ($(element).is(":visible"))+ $.plot($(element), data.get(), options);+ };+ window.setTimeout(redraw, 1);+ $(window).on("resize", redraw);+ data.event(redraw);+}+function varLink(name) {+ return React.createElement("a", { href: "https://hackage.haskell.org/package/shake/docs/Development-Shake.html#v:" + name },+ React.createElement("tt", null, name));+}+function newTable(columns, data, sortColumn, sortDescend) {+ const f = (x) => ({ name: x.field, label: x.label, width: x.width, cellClasses: x.alignRight ? "right" : "" });+ const formatters = {};+ for (const c of columns)+ formatters[c.field] = c.show || ((x) => x);+ const table = new DGTable({+ adjustColumnWidthForSortArrow: false,+ cellFormatter: (val, colname) => formatters[colname](val),+ columns: columns.map(f),+ width: DGTable.Width.SCROLL+ });+ $(table.el).css("height", "100%");+ window.setTimeout(() => {+ table.render();+ table.tableHeightChanged();+ if (sortColumn)+ table.sort(sortColumn, sortDescend);+ table.setRows(data.get(), true);+ }, 1);+ let toRender = false;+ data.event(xs => {+ table.setRows(xs, true);+ if ($(table.el).is(":visible"))+ table.render();+ else+ toRender = true;+ });+ $(window).on("resize", () => {+ if ($(table.el).is(":visible")) {+ table.tableHeightChanged();+ if (toRender) {+ table.render();+ toRender = false;+ }+ }+ });+ return React.createElement("div", { style: "height:100%;width:100%;" }, table.el);+}+// These are global variables mutated/queried by query execution+let environmentAll; // All the profiles+let environmentThis; // The specific profile under test+let environmentGroup; // The group produced as a result+function group(x) {+ environmentGroup.push(x);+ return true;+}+function leaf() {+ return environmentThis.depends.length === 0;+}+function run(i) {+ if (i === undefined)+ return environmentThis.built;+ else+ return environmentThis.built === i;+}+function changed() {+ return environmentThis.changed === environmentThis.built;+}+function visited(i) {+ if (i === undefined)+ return environmentThis.visited;+ else+ return environmentThis.visited === i;+}+function unchanged() {+ return !unchanged();+}+function named(r, groupName) {+ if (r === undefined)+ return environmentThis.name;+ const res = execRegExp(r, environmentThis.name);+ if (res === null) {+ if (groupName === undefined)+ return false;+ else {+ group(groupName);+ return true;+ }+ }+ if (res.length !== 1) {+ for (let i = 1; i < res.length; i++)+ group(res[i]);+ }+ return true;+}+function command(r, groupName) {+ const n = (environmentThis.traces || []).length;+ if (r === undefined)+ return n === 0 ? "" : environmentThis.traces[0].command;+ for (const t of environmentThis.traces) {+ const res = execRegExp(r, t.command);+ if (res === null)+ continue;+ if (res.length !== 1) {+ for (let j = 1; j < res.length; j++)+ group(res[j]);+ }+ return true;+ }+ if (groupName === undefined)+ return false;+ else {+ group(groupName);+ return true;+ }+}+function profileLoaded(profileRaw, buildRaw) {+ $(document.body).empty().append(profileRoot(unraw(profileRaw), unrawBuild(buildRaw)));+}+function unraw(xs) {+ const ans = xs.map((x, i) => ({+ index: i,+ name: x[0],+ execution: x[1],+ built: x[2],+ changed: x[3],+ visited: x[4],+ depends: x.length > 5 ? x[5] : [],+ rdepends: [],+ traces: []+ }));+ for (const p of ans)+ for (const ds of p.depends)+ for (const d of ds)+ ans[d].rdepends.push(p.index);+ return ans;+}+function unrawBuild(b) {+ return { dirtyKeys: b.length > 0 ? b[0] : null };+}+function profileRoot(profile, build) {+ const [s, search] = createSearch(profile);+ const t = createTabs([["Summary", () => reportSummary(profile, build)],+ ["Rules", () => reportRuleTable(profile, search)],+ ["Parallelizability", () => reportParallelism(profile)],+ ["Details", () => reportDetails(profile, search)]+ // , ["Why rebuild", () => reportRebuild(profile, search)]+ ]);+ return React.createElement("table", { class: "fill" },+ React.createElement("tr", null,+ React.createElement("td", { style: "padding-top: 8px; padding-bottom: 8px;" },+ React.createElement("a", { href: "https://shakebuild.com/", style: "font-size: 20px; text-decoration: none; color: #3131a7; font-weight: bold;" }, "Shake profile report"),+ React.createElement("span", { style: "color:gray;white-space:pre;" },+ " - generated at ",+ generated,+ " by hls-graph v",+ version))),+ React.createElement("tr", null,+ React.createElement("td", null, s)),+ React.createElement("tr", null,+ React.createElement("td", { height: "100%" }, t)));+}+function createTabs(xs) {+ const bodies = xs.map(x => {+ const el = React.createElement("div", { style: "padding:5px;width:100%;height:100%;min-width:150px;min-height:150px;overflow:auto;display:none;" });+ const upd = lazy(() => $(el).append(x[1]()));+ return pair(el, upd);+ });+ let lbls = [];+ const f = (i) => () => {+ bodies[i][1]();+ lbls.map((x, j) => $(x).toggleClass("active", i === j));+ bodies.map((x, j) => $(x[0]).toggle(i === j));+ $(window).trigger("resize");+ };+ lbls = xs.map((x, i) => React.createElement("a", { onclick: f(i) }, x[0]));+ f(0)();+ return React.createElement("table", { class: "fill" },+ React.createElement("tr", null,+ React.createElement("td", null,+ React.createElement("table", { width: "100%", style: "border-spacing:0px;" },+ React.createElement("tr", { class: "tabstrip" },+ React.createElement("td", { width: "20", class: "bottom" }, "\u00A0"),+ React.createElement("td", { style: "padding:0px;" }, lbls),+ React.createElement("td", { width: "100%", class: "bottom" }, "\u00A0"))))),+ React.createElement("tr", { height: "100%" },+ React.createElement("td", { style: "background-color:white;" }, bodies.map(fst))));+}+// A mapping from names (rule names or those matched from rule parts)+// to the indicies in profiles.+class Search {+ profile;+ mapping;+ constructor(profile, mapping) {+ this.profile = profile;+ if (mapping !== undefined)+ this.mapping = mapping;+ else {+ this.mapping = {};+ for (const p of profile)+ this.mapping[p.name] = [p.index];+ }+ }+ forEachProfiles(f) {+ for (const s in this.mapping)+ f(this.mapping[s].map(i => this.profile[i]), s);+ }+ forEachProfile(f) {+ this.forEachProfiles((ps, group) => ps.forEach(p => f(p, group)));+ }+ mapProfiles(f) {+ const res = [];+ this.forEachProfiles((ps, group) => res.push(f(ps, group)));+ return res;+ }+ mapProfile(f) {+ const res = [];+ this.forEachProfile((p, group) => res.push(f(p, group)));+ return res;+ }+}+function createSearch(profile) {+ const caption = React.createElement("div", null,+ "Found ",+ profile.length,+ " entries, not filtered or grouped.");+ const input = React.createElement("input", { id: "search", type: "text", value: "", placeholder: "Filter and group", style: "width: 100%; font-size: 16px; border-radius: 8px; padding: 5px 10px; border: 2px solid #999;" });+ const res = new Prop(new Search(profile));+ $(input).on("change keyup paste", () => {+ const s = $(input).val();+ if (s === "") {+ res.set(new Search(profile));+ $(caption).text("Found " + profile.length + " entries, not filtered or grouped.");+ }+ else if (s.indexOf("(") === -1) {+ const mapping = {};+ let found = 0;+ for (const p of profile) {+ if (p.name.indexOf(s) !== -1) {+ found++;+ mapping[p.name] = [p.index];+ }+ }+ res.set(new Search(profile, mapping));+ $(caption).text("Substring filtered to " + found + " / " + profile.length + " entries, not grouped.");+ }+ else {+ let f;+ try {+ f = new Function("return " + s);+ }+ catch (e) {+ $(caption).text("Error compiling function, " + e);+ return;+ }+ const mapping = {};+ let groups = 0;+ let found = 0;+ environmentAll = profile;+ for (const p of profile) {+ environmentThis = p;+ environmentGroup = [];+ let bool;+ try {+ bool = f();+ }+ catch (e) {+ $(caption).text("Error running function, " + e);+ return;+ }+ if (bool) {+ found++;+ const name = environmentGroup.length === 0 ? p.name : environmentGroup.join(" ");+ if (name in mapping)+ mapping[name].push(p.index);+ else {+ groups++;+ mapping[name] = [p.index];+ }+ }+ }+ res.set(new Search(profile, mapping));+ $(caption).text("Function filtered to " + found + " / " + profile.length + " entries, " ++ (groups === found ? "not grouped." : groups + " groups."));+ }+ });+ const body = React.createElement("table", { width: "100%", style: "padding-bottom: 17px;" },+ React.createElement("tr", null,+ React.createElement("td", { width: "100%" }, input),+ React.createElement("td", { style: "padding-left:6px;padding-right: 6px;" }, searchHelp(input))),+ React.createElement("tr", null,+ React.createElement("td", null, caption)));+ return [body, res];+}+function searchHelp(input) {+ const examples = [["Only the last run", "run(0)"],+ ["Only the last visited", "visited(0)"],+ ["Named 'Main'", "named(\"Main\")"],+ ["Group by file extension", "named(/(\\.[_0-9a-z]+)$/)"],+ ["No dependencies (an input)", "leaf()"],+ ["Didn't change when it last rebuilt", "unchanged()"],+ ["Ran 'gcc'", "command(\"gcc\")"]+ ];+ const f = (code) => () => {+ $(input).val((i, x) => x + (x === "" ? "" : " && ") + code);+ $(input).trigger("change");+ };+ const dropdown = React.createElement("div", { class: "dropdown", style: "display:none;" },+ React.createElement("ul", { style: "padding-left:30px;" }, examples.map(([desc, code]) => React.createElement("li", null,+ React.createElement("a", { onclick: f(code) },+ React.createElement("tt", null, code)),+ " ",+ React.createElement("span", { class: "note" }, desc)))));+ const arrow_down = React.createElement("span", { style: "vertical-align:middle;font-size:80%;" }, "\u25BC");+ const arrow_up = React.createElement("span", { style: "vertical-align:middle;font-size:80%;display:none;" }, "\u25B2");+ const show_inner = () => { $(dropdown).toggle(); $(arrow_up).toggle(); $(arrow_down).toggle(); };+ return React.createElement("div", null,+ React.createElement("button", { style: "white-space:nowrap;padding-top:5px;padding-bottom:5px;", onclick: show_inner },+ React.createElement("b", { style: "font-size:150%;vertical-align:middle;" }, "+"),+ "\u00A0 Filter and Group \u00A0",+ arrow_down,+ arrow_up),+ dropdown);+}+function initProgress() {+ $(function () {+ $(".version").html("Generated by <a href='https://shakebuild.com'>Shake " + version + "</a>.");+ $("#output").html("");+ for (const x of progress) {+ var actual = [];+ var ideal = [];+ // Start at t = 5 seconds, since the early progress jumps a lot+ for (var t = 5; t < x.values.length; t++) {+ var y = x.values[t];+ actual.push([y.idealSecs, y.actualSecs]);+ ideal.push([y.idealSecs, y.idealSecs]);+ }+ var ys = [{ data: ideal, color: "gray" }, { label: x.name, data: actual, color: "red" }];+ var div = $("<div class='plot'>");+ $("#output").append(div);+ $.plot(div, ys, {+ xaxis: {+ transform: function (v) { return -v; },+ inverseTransform: function (v) { return -v; }+ }+ });+ }+ });+}+// Stuff that Shake generates and injects in+function untraced(p) {+ return Math.max(0, p.execution - p.traces.map(t => t.stop - t.start).sum());+}+/////////////////////////////////////////////////////////////////////+// BASIC UI TOOLKIT+class Prop {+ val;+ callback;+ constructor(val) { this.val = val; this.callback = () => { return; }; }+ get() { return this.val; }+ set(val) {+ this.val = val;+ this.callback(val);+ }+ event(next) {+ const old = this.callback;+ this.callback = val => { old(val); next(val); };+ next(this.val);+ }+ map(f) {+ const res = new Prop(f(this.get()));+ this.event(a => res.set(f(a)));+ return res;+ }+}+jQuery.fn.enable = function (x) {+ // Set the values to enabled/disabled+ return this.each(function () {+ if (x)+ $(this).removeAttr("disabled");+ else+ $(this).attr("disabled", "disabled");+ });+};+/////////////////////////////////////////////////////////////////////+// BROWSER HELPER METHODS+// Given "?foo=bar&baz=1" returns {foo:"bar",baz:"1"}+function uriQueryParameters(s) {+ // From https://stackoverflow.com/questions/901115/get-querystring-values-with-jquery/3867610#3867610+ const params = {};+ const a = /\+/g; // Regex for replacing addition symbol with a space+ const r = /([^&=]+)=?([^&]*)/g;+ const d = (x) => decodeURIComponent(x.replace(a, " "));+ const q = s.substring(1);+ while (true) {+ const e = r.exec(q);+ if (!e)+ break;+ params[d(e[1])] = d(e[2]);+ }+ return params;+}+/////////////////////////////////////////////////////////////////////+// STRING FORMATTING+function showTime(x) {+ function digits(x) { const s = String(x); return s.length === 1 ? "0" + s : s; }+ if (x >= 3600) {+ x = Math.round(x / 60);+ return Math.floor(x / 60) + "h" + digits(x % 60) + "m";+ }+ else if (x >= 60) {+ x = Math.round(x);+ return Math.floor(x / 60) + "m" + digits(x % 60) + "s";+ }+ else+ return x.toFixed(2) + "s";+}+function showPerc(x) {+ return (x * 100).toFixed(2) + "%";+}+function showInt(x) {+ // From https://stackoverflow.com/questions/2901102/how-to-print-a-number-with-commas-as-thousands-separators-in-javascript+ // Show, with commas+ return x.toString().replace(/\B(?=(\d{3})+(?!\d))/g, ",");+}+function showRun(run) {+ return run === 0 ? "Latest run" : run + " run" + plural(run) + " ago";+}+function plural(n, not1 = "s", is1 = "") {+ return n === 1 ? is1 : not1;+}+/////////////////////////////////////////////////////////////////////+// MISC+function compareFst(a, b) {+ return a[0] - b[0];+}+function compareSnd(a, b) {+ return a[1] - b[1];+}+function compareSndRev(a, b) {+ return b[1] - a[1];+}+function pair(a, b) {+ return [a, b];+}+function triple(a, b, c) {+ return [a, b, c];+}+function fst([x, _]) {+ return x;+}+function snd([_, x]) {+ return x;+}+function execRegExp(r, s) {+ if (typeof r === "string")+ return s.indexOf(r) === -1 ? null : [];+ else+ return r.exec(s);+}+function cache(key, op) {+ const store = {};+ return k => {+ const s = key(k);+ if (!(s in store))+ store[s] = op(k);+ return store[s];+ };+}+function lazy(thunk) {+ let store = null;+ let done = false;+ return () => {+ if (!done) {+ store = thunk();+ done = true;+ }+ return store;+ };+}+Array.prototype.sum = function () {+ let res = 0;+ for (const x of this)+ res += x;+ return res;+};+Array.prototype.insertSorted = function (x, compare) {+ let start = 0;+ let stop = this.length - 1;+ let middle = 0;+ while (start <= stop) {+ middle = Math.floor((start + stop) / 2);+ if (compare(this[middle], x) > 0)+ stop = middle - 1;+ else+ start = middle + 1;+ }+ this.splice(start, 0, x);+ return this;+};+Array.prototype.concatLength = function () {+ let res = 0;+ for (const x of this)+ res += x.length;+ return res;+};+Array.prototype.sortOn = function (f) {+ return this.map(x => pair(f(x), x)).sort(compareFst).map(snd);+};+Array.prototype.last = function () {+ return this[this.length - 1];+};+Array.prototype.maximum = function (def) {+ if (this.length === 0)+ return def;+ let res = this[0];+ for (let i = 1; i < this.length; i++)+ res = Math.max(res, this[i]);+ return res;+};+Array.prototype.minimum = function (def) {+ if (this.length === 0)+ return def;+ let res = this[0];+ for (let i = 1; i < this.length; i++)+ res = Math.min(res, this[i]);+ return res;+};+// Use JSX with el instead of React.createElement+// Originally from https://gist.github.com/sergiodxa/a493c98b7884128081bb9a281952ef33+// our element factory+function createElement(type, props, ...children) {+ const element = document.createElement(type);+ for (const name in props || {}) {+ if (name.substr(0, 2) === "on")+ element.addEventListener(name.substr(2), props[name]);+ else+ element.setAttribute(name, props[name]);+ }+ for (const child of children.flat(10)) {+ const c = typeof child === "object" ? child : document.createTextNode(child.toString());+ element.appendChild(c);+ }+ return element;+}+// How .tsx gets desugared+const React = { createElement };+function reportCmdPlot(profile) {+ // first find the end point+ const runs = findRuns(profile);+ if (runs.length === 0) {+ return React.createElement("div", null,+ React.createElement("h2", null, "No data found"),+ React.createElement("p", null, "The Shake database contains no rules which ran traced commands."),+ React.createElement("p", null,+ "You can populate this information by using ",+ varLink("cmd"),+ " or wrapping your ",+ React.createElement("tt", null, "IO"),+ " actions in ",+ varLink("traced"),+ "."));+ }+ const combo = React.createElement("select", null,+ runs.map(([run, time], i) => React.createElement("option", null,+ showRun(run) + " (" + showTime(time) + ") ",+ i === 0 ? "" : " - may be incomplete")),+ ";");+ const warning = React.createElement("i", null);+ const plot = React.createElement("div", { style: "width:100%; height:100%;" });+ const plotData = new Prop([]);+ bindPlot(plot, plotData, {+ legend: { show: true, position: "nw", sorted: "reverse" },+ series: { stack: true, lines: { fill: 1, lineWidth: 0 } },+ yaxis: { min: 0 },+ xaxis: { tickFormatter: showTime }+ });+ function setPlotData(runsIndex) {+ const [run, end] = runs[runsIndex];+ const profileRun = profile.filter(p => p.built === run);+ // Make sure we max(0,) every step in the process, in case one does parallelism of threads+ const missing = profileRun.map(untraced).sum();+ $(warning).text(missing < 1 ? "" : "Warning: " + showTime(missing) + " of execution was not traced.");+ const series = calcPlotData(end, profileRun, 100);+ const res = [];+ for (const s in series)+ res.push({ label: s, data: series[s].map((x, i) => pair(end * i / 100, x)) });+ plotData.set(res);+ }+ setPlotData(0);+ $(combo).change(() => setPlotData(combo.selectedIndex));+ return React.createElement("table", { class: "fill" },+ React.createElement("tr", null,+ React.createElement("td", { width: "100%", style: "text-align:center;" },+ React.createElement("h2", null, "Number of commands executing over time")),+ React.createElement("td", null, combo)),+ React.createElement("tr", null,+ React.createElement("td", { height: "100%", colspan: "2" }, plot)),+ React.createElement("tr", null,+ React.createElement("td", { colspan: "2", style: "text-align:center;" },+ "Time since the start of building. ",+ warning)));+}+// Find which runs had traced commands and when the last stopped, sort so most recent first+function findRuns(profile) {+ const runs = {};+ for (const p of profile) {+ if (p.traces.length > 0) {+ if (p.traces.length === 1 && p.traces[0].command === "")+ continue; // the fake end command+ const old = runs[p.built];+ const end = p.traces.last().stop;+ runs[p.built] = old === undefined ? end : Math.max(old, end);+ }+ }+ const runsList = [];+ for (const i in runs)+ runsList.push(pair(Number(i), runs[i]));+ runsList.sort(compareFst);+ return runsList;+}+function calcPlotData(end, profile, buckets) {+ const ans = {};+ for (const p of profile) {+ for (const t of p.traces) {+ let xs;+ if (t.command in ans)+ xs = ans[t.command];+ else {+ xs = [];+ for (let i = 0; i < buckets; i++)+ xs.push(0); // fill with 1 more element, but the last bucket will always be 0+ ans[t.command] = xs;+ }+ const start = t.start * buckets / end;+ const stop = t.stop * buckets / end;+ if (Math.floor(start) === Math.floor(stop))+ xs[Math.floor(start)] += stop - start;+ else {+ for (let j = Math.ceil(start); j < Math.floor(stop); j++)+ xs[j]++;+ xs[Math.floor(start)] += Math.ceil(start) - start;+ xs[Math.floor(stop)] += stop - Math.floor(stop);+ }+ }+ }+ return ans;+}+function reportCmdTable(profile, search) {+ const columns = [{ field: "name", label: "Name", width: 200 },+ { field: "count", label: "Count", width: 65, alignRight: true, show: showInt },+ { field: "total", label: "Total", width: 75, alignRight: true, show: showTime },+ { field: "average", label: "Average", width: 75, alignRight: true, show: showTime },+ { field: "max", label: "Max", width: 75, alignRight: true, show: showTime }+ ];+ return newTable(columns, search.map(cmdData), "total", true);+}+function cmdData(search) {+ const res = {};+ search.forEachProfile(p => {+ for (const t of p.traces) {+ const time = t.stop - t.start;+ if (t.command === "")+ continue; // do nothing+ else if (!(t.command in res))+ res[t.command] = { count: 1, total: time, max: time };+ else {+ const ans = res[t.command];+ ans.count++;+ ans.total += time;+ ans.max = Math.max(ans.max, time);+ }+ }+ });+ const res2 = [];+ for (const i in res)+ res2.push({ name: i, average: res[i].total / res[i].count, ...res[i] });+ return res2;+}+function reportDetails(profile, search) {+ const result = React.createElement("div", { class: "details" });+ const self = new Prop(0);+ search.event(xs => self.set(xs.mapProfile((p, _) => p.index).maximum()));+ const f = (i) => React.createElement("a", { onclick: () => self.set(i) }, profile[i].name);+ self.event(i => {+ const p = profile[i];+ const content = React.createElement("ul", null,+ React.createElement("li", null,+ React.createElement("b", null, "Name:"),+ " ",+ p.name),+ React.createElement("li", null,+ React.createElement("b", null, "Built:"),+ " ",+ showRun(p.built)),+ React.createElement("li", null,+ React.createElement("b", null, "Changed:"),+ " ",+ showRun(p.changed)),+ React.createElement("li", null,+ React.createElement("b", null, "Execution time:"),+ showTime(p.execution)),+ React.createElement("li", null,+ React.createElement("b", null, "Traced commands:"),+ React.createElement("ol", null, p.traces.map(t => React.createElement("li", null,+ t.command,+ " took ",+ showTime(t.stop - t.start))))),+ React.createElement("li", null,+ React.createElement("b", null, "Dependencies:"),+ React.createElement("ol", null, p.depends.map(ds => React.createElement("li", null,+ React.createElement("ul", null, ds.map(d => React.createElement("li", null, f(d)))))))),+ React.createElement("li", null,+ React.createElement("b", null, "Things that depend on me:"),+ React.createElement("ul", null, p.rdepends.map(d => React.createElement("li", null, f(d))))));+ $(result).empty().append(content);+ });+ return result;+}+function reportParallelism(profile) {+ // now simulate for -j1 .. -j24+ const plotData = [{ label: "Realistic (based on current dependencies)", data: [], color: "#3131a7" },+ { label: "Ideal (if no dependencies and perfect speedup)", data: [], color: "green" },+ { label: "Gap", data: [], color: "orange" }+ ];+ let threads1;+ for (let threads = 1; threads <= 24; threads++) {+ const taken = simulateThreads(profile, threads)[0];+ if (threads === 1)+ threads1 = taken;+ plotData[0].data.push([threads, taken]);+ plotData[1].data.push([threads, threads1 / threads]);+ plotData[2].data.push([threads, Math.max(0, taken - (threads1 / threads))]);+ }+ const plot = React.createElement("div", { style: "width:100%; height:100%;" });+ bindPlot(plot, new Prop(plotData), {+ xaxis: { tickDecimals: 0 },+ yaxis: { min: 0, tickFormatter: showTime }+ });+ return React.createElement("table", { class: "fill" },+ React.createElement("tr", null,+ React.createElement("td", { style: "text-align:center;" },+ React.createElement("h2", null, "Time to build at different number of threads"))),+ React.createElement("tr", null,+ React.createElement("td", { height: "100%" }, plot)),+ React.createElement("tr", null,+ React.createElement("td", { style: "text-align:center;" }, "Number of threads available.")));+}+// Simulate running N threads over the profile, return:+// [total time take, point at which each entry kicked off]+function simulateThreads(profile, threads) {+ // How far are we through this simulation+ let timestamp = 0;+ // Who is currently running, with the highest seconds FIRST+ const running = [];+ const started = [];+ // Things that are done+ const ready = profile.filter(x => x.depends.length === 0);+ const waiting = profile.map(x => x.depends.concatLength()); // number I am waiting on before I am done+ function runningWait() {+ const [ind, time] = running.pop();+ timestamp = time;+ for (const d of profile[ind].rdepends) {+ waiting[d]--;+ if (waiting[d] === 0)+ ready.push(profile[d]);+ }+ }+ while (true) {+ // Queue up as many people as we can+ while (running.length < threads && ready.length > 0) {+ const p = ready.pop();+ started[p.index] = timestamp;+ running.insertSorted([p.index, timestamp + p.execution], compareSndRev);+ }+ if (running.length === 0) {+ if (waiting.maximum(0) > 0)+ throw new Error("Failed to run all tasks");+ return [timestamp, started];+ }+ runningWait();+ }+}+function reportRebuild(profile, search) {+ const depth = [];+ for (const p of profile) {+ depth[p.index] = p.depends.flat().map(d => depth[d] + 1).maximum(0);+ }+ const ind = search.get().mapProfile((p, _) => p.index).sortOn(i => -depth[i])[0];+ const p = profile[ind];+ function f(p) {+ const res = [];+ while (p.depends.length !== 0) {+ const ds = p.depends.flat().sortOn(i => -depth[i]);+ res.push(React.createElement("li", null,+ React.createElement("select", { style: "width:400px;" }, ds.slice(0, 1).map(x => React.createElement("option", null, profile[x].name)))));+ p = profile[ds[0]];+ }+ return res;+ }+ return React.createElement("div", null,+ React.createElement("h2", null, "Why did it rebuild?"),+ React.createElement("p", null,+ "Rule ",+ p.name + " " + (p.built === 0 ? "rebuild in the last run" : "did not rebuild")),+ React.createElement("ul", null, f(p)));+}+function reportRuleTable(profile, search) {+ const [etimes, wtimes] = calcEWTimes(profile, 24);+ const columns = [{ field: "name", label: "Name", width: 400 },+ { field: "count", label: "Count", width: 65, alignRight: true, show: showInt },+ { field: "leaf", label: "Leaf", width: 60, alignRight: true },+ { field: "visited", label: "Visit", width: 50, alignRight: true },+ { field: "run", label: "Run", width: 50, alignRight: true },+ { field: "changed", label: "Change", width: 60, alignRight: true },+ { field: "time", label: "Time", width: 75, alignRight: true, show: showTime },+ { field: "etime", label: "ETime", width: 75, alignRight: true, show: showTime },+ { field: "wtime", label: "WTime", width: 75, alignRight: true, show: showTime }+ ];+ return newTable(columns, search.map(s => ruleData(etimes, wtimes, s)), "time", true);+}+// Calculate the exclusive time of each rule at some number of threads+function calcEWTimes(profile, threads) {+ const [_, started] = simulateThreads(profile, threads);+ const starts = started.map((s, i) => pair(i, s)).sort(compareSnd);+ const costs = starts.map(([ind, start], i) => {+ // find out who else runs before I finish+ const execution = profile[ind].execution;+ const end = start + execution;+ let overlap = 0; // how much time I am overlapped for+ let exclusive = 0; // how much time I am the only runner+ let finisher = start; // the first overlapping person to finish+ for (let j = i + 1; j < starts.length; j++) {+ const [jInd, jStarts] = starts[j];+ if (jStarts > end)+ break;+ overlap += Math.min(end - jStarts, profile[jInd].execution);+ exclusive += Math.max(0, Math.min(jStarts, end) - finisher);+ finisher = Math.max(finisher, jStarts + profile[jInd].execution);+ }+ exclusive += Math.max(0, end - finisher);+ return triple(ind, execution === 0 ? 0 : execution * (execution / (execution + overlap)), exclusive);+ });+ const etimes = [];+ const wtimes = [];+ for (const [ind, etime, wtime] of costs) {+ etimes[ind] = etime;+ wtimes[ind] = wtime;+ }+ return [etimes, wtimes];+}+function ruleData(etimes, wtimes, search) {+ return search.mapProfiles((ps, name) => ({+ name,+ count: ps.length,+ leaf: ps.every(p => p.depends.length === 0),+ run: ps.map(p => p.built).minimum(),+ visited: ps.map(p => p.visited).minimum(),+ changed: ps.some(p => p.built === p.changed),+ time: ps.map(p => p.execution).sum(),+ etime: ps.map(p => etimes[p.index]).sum(),+ wtime: ps.map(p => wtimes[p.index]).sum(),+ }));+}+function reportSummary(profile, build) {+ let countLast = 0; // number of rules run in the last run+ let visitedLast = 0; // number of rules visited in the last run+ let highestRun = 0; // highest run you have seen (add 1 to get the count of runs)+ let sumExecution = 0; // build time in total+ let sumExecutionLast = 0; // build time in total+ let countTrace = -1;+ let countTraceLast = -1; // traced commands run+ // start both are -1 because the end command will have run in the previous step+ let maxTraceStopLast = 0; // time the last traced command stopped+ for (const p of profile) {+ sumExecution += p.execution;+ highestRun = Math.max(highestRun, p.changed); // changed is always greater or equal to built+ countTrace += p.traces.length;+ if (p.built === 0) {+ sumExecutionLast += p.execution;+ countLast++;+ countTraceLast += p.traces.length;+ if (p.traces.length > 0)+ maxTraceStopLast = Math.max(maxTraceStopLast, p.traces.last().stop);+ }+ if (p.visited === 0) {+ visitedLast++;+ }+ }+ return React.createElement("div", null,+ React.createElement("h2", null, "Totals"),+ React.createElement("ul", null,+ React.createElement("li", null,+ React.createElement("b", null, "Runs:"),+ " ",+ showInt(highestRun + 1),+ " ",+ React.createElement("span", { class: "note" }, "total number of runs so far.")),+ React.createElement("li", null,+ React.createElement("b", null, "Rules:"),+ " ",+ showInt(profile.length),+ " (",+ showInt(countLast),+ " in last run) ",+ React.createElement("span", { class: "note" }, "number of defined build rules."))),+ React.createElement("h2", null, "Performance"),+ React.createElement("ul", null,+ React.createElement("li", null,+ React.createElement("b", null, "Build time:"),+ " ",+ showTime(sumExecution),+ " ",+ React.createElement("span", { class: "note" }, "how long a complete build would take single threaded.")),+ React.createElement("li", null,+ React.createElement("b", null, "Last build time:"),+ " ",+ showTime(maxTraceStopLast),+ " ",+ React.createElement("span", { class: "note" }, "how long the last build take.")),+ React.createElement("li", null,+ React.createElement("b", null, "Parallelism:"),+ " ",+ (maxTraceStopLast === 0 ? 0 : sumExecutionLast / maxTraceStopLast).toFixed(2),+ " ",+ React.createElement("span", { class: "note" }, "average number of commands executing simultaneously in the last build.")),+ React.createElement("li", null,+ React.createElement("b", null, "Speculative critical path:"),+ " ",+ showTime(speculativeCriticalPath(profile)),+ " ",+ React.createElement("span", { class: "note" }, "how long it would take on infinite CPUs.")),+ React.createElement("li", null,+ React.createElement("b", null, "Precise critical path:"),+ " ",+ showTime(preciseCriticalPath(profile)),+ " ",+ React.createElement("span", { class: "note" }, "critical path not speculatively executing."))),+ React.createElement("h2", null, "This run"),+ React.createElement("ul", null,+ React.createElement("li", null,+ React.createElement("b", null, "Rules built:"),+ " ",+ showInt(countLast),+ " ",+ React.createElement("span", { class: "note" }, "Total number of rules built in this run")),+ React.createElement("li", null,+ React.createElement("b", null, "Rules visited:"),+ " ",+ showInt(visitedLast - countLast),+ " ",+ React.createElement("span", { class: "note" }, "Total number of rules looked up from the values store in this run")),+ React.createElement("li", null,+ React.createElement("b", null, "Dirty set:"),+ renderDirtySet(build, profile))));+}+function renderDirtySet(build, profile) {+ if (build.dirtyKeys === null) {+ return "ALL";+ }+ else {+ return React.createElement("ul", null, build.dirtyKeys.map(d => { return React.createElement("li", null, profile[d - 1].name); }));+ }+}+function speculativeCriticalPath(profile) {+ const criticalPath = []; // the critical path to any element+ let maxCriticalPath = 0;+ for (const p of profile) {+ let cost = 0;+ for (const ds of p.depends)+ for (const d of ds)+ cost = Math.max(cost, criticalPath[d]);+ cost += p.execution;+ maxCriticalPath = Math.max(cost, maxCriticalPath);+ criticalPath[p.index] = cost;+ }+ return maxCriticalPath;+}+/*+Calculating a precise critical path, taking into account the deep dependeny structure, is non-obvious.+Dependencies have the type [{X}], e.g:++ X = [{a,b},{c,d}]++That is r builds a and b, then after those both complete (assuming they don't change), it builds c and d,+then it is finished. Importantly, r doesn't start building c/d until after a and b have finished. This+detail extends the critical path.++To calculate the precise critical path, we simulate with the notion of demand and waiting.+*/+function preciseCriticalPath(profile) {+ const waiting = profile.map(x => x.depends.concatLength()); // number I am waiting on before I am done+ const demanded = []; // I have been demanded by someone+ const oncomplete = []; // Completion functions+ const complete = []; // Who is complete already+ const running = [];+ let timestamp = 0;+ // demand dependency set N of a rule+ function demandN(p, round) {+ for (; round < p.depends.length; round++) {+ let todo = p.depends[round].length; // Number before we continue+ const step = () => {+ todo--;+ if (todo === 0)+ demandN(p, round + 1);+ };+ for (const d of p.depends[round]) {+ if (complete[d])+ todo--;+ else {+ const old = oncomplete[d];+ oncomplete[d] = !old ? step : () => { old(); step(); };+ demand(profile[d]);+ }+ }+ if (todo !== 0)+ break;+ // todo === 0, so continue (equivalent to calling step but tail recursive)+ }+ }+ // demand a particular rule+ function demand(p) {+ if (demanded[p.index])+ return;+ demanded[p.index] = true;+ if (waiting[p.index] === 0)+ running.insertSorted([p.index, timestamp + p.execution], compareSndRev);+ else+ demandN(p, 0);+ }+ // We don't know the targets we ask for, so we approximate by saying the ones which nothing depends on+ for (const p of profile) {+ if (p.rdepends.length === 0)+ demand(p);+ }+ while (running.length > 0) {+ const [ind, time] = running.pop();+ timestamp = time;+ complete[ind] = true;+ if (oncomplete[ind]) {+ oncomplete[ind]();+ delete oncomplete[ind];+ }+ for (const d of profile[ind].rdepends) {+ waiting[d]--;+ if (waiting[d] === 0 && demanded[d])+ running.insertSorted([d, timestamp + profile[d].execution], compareSndRev);+ }+ }+ for (let i = 0; i < profile.length; i++)+ if (!complete[i])+ throw new Error("Failed to run all tasks");+ return timestamp;+}
src/Development/IDE/Graph.hs view
@@ -4,22 +4,26 @@ shakeOptions, Rules, Action, action,- actionFinally, actionBracket, actionCatch,- Shake.ShakeException(..),+ Key(..),+ actionFinally, actionBracket, actionCatch, actionFork, -- * Configuration ShakeOptions(shakeAllowRedefineRules, shakeThreads, shakeFiles, shakeExtra), getShakeExtra, getShakeExtraRules, newShakeExtra, -- * Explicit parallelism parallel, -- * Oracle rules- Shake.ShakeValue, Shake.RuleResult,+ ShakeValue, RuleResult, -- * Special rules alwaysRerun, -- * Batching reschedule,+ -- * Actions for inspecting the keys in the database+ getDirtySet,+ getKeysAndVisitedAge, ) where +import Development.IDE.Graph.Database import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Rules-import qualified Development.Shake as Shake+import Development.IDE.Graph.Internal.Types
src/Development/IDE/Graph/Classes.hs view
@@ -1,6 +1,8 @@ module Development.IDE.Graph.Classes(- Show(..), Typeable, Eq(..), Hashable(..), Binary(..), NFData(..)+ Show(..), Typeable, Eq(..), Hashable(..), NFData(..) ) where -import Development.Shake.Classes+import Control.DeepSeq+import Data.Hashable+import Data.Typeable
src/Development/IDE/Graph/Database.hs view
@@ -1,36 +1,86 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} module Development.IDE.Graph.Database(- Shake.ShakeDatabase,- SomeShakeValue(..),+ ShakeDatabase,+ ShakeValue, shakeOpenDatabase,+ shakeRunDatabase, shakeRunDatabaseForKeys,- Shake.shakeProfileDatabase,- ) where--import Data.Typeable+ shakeProfileDatabase,+ shakeGetBuildStep,+ shakeGetDirtySet,+ shakeGetCleanKeys+ ,shakeGetBuildEdges) where+import Data.Dynamic+import Data.IORef (readIORef)+import Data.Maybe+import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action+import Development.IDE.Graph.Internal.Database+import qualified Development.IDE.Graph.Internal.Ids as Ids import Development.IDE.Graph.Internal.Options+import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules-import Development.Shake (ShakeValue)-import Development.Shake.Classes-import qualified Development.Shake.Database as Shake+import Development.IDE.Graph.Internal.Types -shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO Shake.ShakeDatabase, IO ())-shakeOpenDatabase a b = Shake.shakeOpenDatabase (fromShakeOptions a) (fromRules b)+data ShakeDatabase = ShakeDatabase !Int [Action ()] Database -data SomeShakeValue = forall k . ShakeValue k => SomeShakeValue k-instance Eq SomeShakeValue where SomeShakeValue a == SomeShakeValue b = cast a == Just b-instance Hashable SomeShakeValue where hashWithSalt s (SomeShakeValue x) = hashWithSalt s x-instance Show SomeShakeValue where show (SomeShakeValue x) = show x+-- Placeholder to be the 'extra' if the user doesn't set it+data NonExportedType = NonExportedType +shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())+shakeOpenDatabase opts rules = pure (shakeNewDatabase opts rules, pure ())++shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase+shakeNewDatabase opts rules = do+ let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts+ (theRules, actions) <- runRules extra rules+ db <- newDatabase extra theRules+ pure $ ShakeDatabase (length actions) actions db++shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])+shakeRunDatabase = shakeRunDatabaseForKeys Nothing++-- | Returns the set of dirty keys annotated with their age (in # of builds)+shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)]+shakeGetDirtySet (ShakeDatabase _ _ db) =+ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db++-- | Returns the build number+shakeGetBuildStep :: ShakeDatabase -> IO Int+shakeGetBuildStep (ShakeDatabase _ _ db) = do+ Step s <- readIORef $ databaseStep db+ return s++-- Only valid if we never pull on the results, which we don't+unvoid :: Functor m => m () -> m a+unvoid = fmap undefined+ shakeRunDatabaseForKeys- :: Maybe [SomeShakeValue]+ :: Maybe [Key] -- ^ Set of keys changed since last run. 'Nothing' means everything has changed- -> Shake.ShakeDatabase+ -> ShakeDatabase -> [Action a] -> IO ([a], [IO ()])-shakeRunDatabaseForKeys _keys a b =- -- Shake upstream does not accept the set of keys changed yet- -- https://github.com/ndmitchell/shake/pull/802- Shake.shakeRunDatabase a (map fromAction b)+shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do+ incDatabase db keysChanged+ as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2+ return (as, [])++-- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run.+shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()+shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s++-- | Returns the clean keys in the database+shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result )]+shakeGetCleanKeys (ShakeDatabase _ _ db) = do+ keys <- Ids.elems $ databaseValues db+ return [ (k,res) | (k, Clean res) <- keys]++-- | Returns the total count of edges in the build graph+shakeGetBuildEdges :: ShakeDatabase -> IO Int+shakeGetBuildEdges (ShakeDatabase _ _ db) = do+ keys <- Ids.elems $ databaseValues db+ let ress = mapMaybe (getResult . snd) keys+ return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress
src/Development/IDE/Graph/Internal/Action.hs view
@@ -1,38 +1,138 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Action where+module Development.IDE.Graph.Internal.Action+( ShakeValue+, actionFork+, actionBracket+, actionCatch+, actionFinally+, alwaysRerun+, apply1+, apply+, parallel+, reschedule+, runActions+, Development.IDE.Graph.Internal.Action.getDirtySet+, getKeysAndVisitedAge+) where +import Control.Concurrent.Async import Control.Exception-import Control.Monad.Fail import Control.Monad.IO.Class-import qualified Development.Shake as Shake-import Development.Shake.Classes-import qualified Development.Shake.Rule as Shake+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.IORef+import Development.IDE.Graph.Classes+import Development.IDE.Graph.Internal.Database+import Development.IDE.Graph.Internal.Rules (RuleResult)+import Development.IDE.Graph.Internal.Types+import System.Exit -newtype Action a = Action {fromAction :: Shake.Action a}- deriving (Monad, Applicative, Functor, MonadIO, MonadFail)+type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) +-- | Always rerun this rule when dirty, regardless of the dependencies. alwaysRerun :: Action ()-alwaysRerun = Action Shake.alwaysRerun+alwaysRerun = do+ ref <- Action $ asks actionDeps+ liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>) +-- No-op for now reschedule :: Double -> Action ()-reschedule = Action . Shake.reschedule+reschedule _ = pure () parallel :: [Action a] -> Action [a]-parallel = Action . Shake.parallel . map fromAction+parallel [] = pure []+parallel [x] = fmap (:[]) x+parallel xs = do+ a <- Action ask+ deps <- liftIO $ readIORef $ actionDeps a+ case deps of+ UnknownDeps ->+ -- if we are already in the rerun mode, nothing we do is going to impact our state+ liftIO $ mapConcurrently (ignoreState a) xs+ deps -> do+ (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs+ liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps+ pure res+ where+ usingState a x = do+ ref <- newIORef mempty+ res <- runReaderT (fromAction x) a{actionDeps=ref}+ deps <- readIORef ref+ pure (deps, res) +ignoreState :: SAction -> Action b -> IO b+ignoreState a x = do+ ref <- newIORef mempty+ runReaderT (fromAction x) a{actionDeps=ref}++actionFork :: Action a -> (Async a -> Action b) -> Action b+actionFork act k = do+ a <- Action ask+ deps <- liftIO $ readIORef $ actionDeps a+ let db = actionDatabase a+ case deps of+ UnknownDeps -> do+ -- if we are already in the rerun mode, nothing we do is going to impact our state+ [res] <- liftIO $ withAsync (ignoreState a act) $ \as -> runActions db [k as]+ return res+ _ ->+ error "please help me"++isAsyncException :: SomeException -> Bool+isAsyncException e+ | Just (_ :: AsyncCancelled) <- fromException e = True+ | Just (_ :: AsyncException) <- fromException e = True+ | Just (_ :: ExitCode) <- fromException e = True+ | otherwise = False++ actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a-actionCatch a b = Action $ Shake.actionCatch (fromAction a) (fromAction . b)+actionCatch a b = do+ v <- Action ask+ Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v)+ where+ -- Catch only catches exceptions that were caused by this code, not those that+ -- are a result of program termination+ f e | isAsyncException e = Nothing+ | otherwise = fromException e actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c-actionBracket a b c = Action $ Shake.actionBracket a b (fromAction . c)+actionBracket a b c = do+ v <- Action ask+ Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v) actionFinally :: Action a -> IO b -> Action a-actionFinally a b = Action $ Shake.actionFinally (fromAction a) b+actionFinally a b = do+ v <- Action ask+ Action $ lift $ finally (runReaderT (fromAction a) v) b -apply1 :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => key -> Action value-apply1 = Action . Shake.apply1+apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value+apply1 k = head <$> apply [k] -apply :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => [key] -> Action [value]-apply = Action . Shake.apply+apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]+apply ks = do+ db <- Action $ asks actionDatabase+ (is, vs) <- liftIO $ build db ks+ ref <- Action $ asks actionDeps+ liftIO $ modifyIORef ref (ResultDeps is <>)+ pure vs++runActions :: Database -> [Action a] -> IO [a]+runActions db xs = do+ deps <- newIORef mempty+ runReaderT (fromAction $ parallel xs) $ SAction db deps++-- | Returns the set of dirty keys annotated with their age (in # of builds)+getDirtySet :: Action [(Key, Int)]+getDirtySet = do+ db <- getDatabase+ liftIO $ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db++getKeysAndVisitedAge :: Action [(Key, Int)]+getKeysAndVisitedAge = do+ db <- getDatabase+ liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db
+ src/Development/IDE/Graph/Internal/Database.hs view
@@ -0,0 +1,301 @@+-- We deliberately want to ensure the function we add to the rule database+-- has the constraints we need on it when we get it out.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where++import Control.Concurrent.Async+import Control.Concurrent.Extra+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Strict as State+import Data.Dynamic+import Data.Either+import Data.Foldable (traverse_)+import Data.IORef.Extra+import Data.IntSet (IntSet)+import qualified Data.IntSet as Set+import Data.Maybe+import Data.Tuple.Extra+import Development.IDE.Graph.Classes+import qualified Development.IDE.Graph.Internal.Ids as Ids+import Development.IDE.Graph.Internal.Intern+import qualified Development.IDE.Graph.Internal.Intern as Intern+import Development.IDE.Graph.Internal.Rules+import Development.IDE.Graph.Internal.Types+import System.IO.Unsafe+import System.Time.Extra (duration)++newDatabase :: Dynamic -> TheRules -> IO Database+newDatabase databaseExtra databaseRules = do+ databaseStep <- newIORef $ Step 0+ databaseLock <- newLock+ databaseIds <- newIORef Intern.empty+ databaseValues <- Ids.empty+ databaseReverseDeps <- Ids.empty+ databaseReverseDepsLock <- newLock+ pure Database{..}++-- | Increment the step and mark dirty+incDatabase :: Database -> Maybe [Key] -> IO ()+-- all keys are dirty+incDatabase db Nothing = do+ modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1+ withLock (databaseLock db) $+ Ids.forMutate (databaseValues db) $ \_ -> second $ \case+ Clean x -> Dirty (Just x)+ Dirty x -> Dirty x+ Running _ _ x -> Dirty x+-- only some keys are dirty+incDatabase db (Just kk) = do+ modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1+ intern <- readIORef (databaseIds db)+ let dirtyIds = mapMaybe (`Intern.lookup` intern) kk+ transitiveDirtyIds <- transitiveDirtySet db dirtyIds+ withLock (databaseLock db) $+ Ids.forMutate (databaseValues db) $ \i -> \case+ (k, Running _ _ x) -> (k, Dirty x)+ (k, Clean x) | i `Set.member` transitiveDirtyIds ->+ (k, Dirty (Just x))+ other -> other+++-- | 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 -> [key] -> IO ([Id], [value])+build db keys = do+ (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<< builder db (map (Right . Key) keys)+ pure (ids, map (asV . resultValue) vs)+ where+ asV :: Value -> value+ asV (Value x) = unwrapDynamic x++-- | Build a list of keys and return their results.+-- 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 -> [Either Id Key] -> AIO (Either [(Id, Result)] (IO [(Id, Result)]))+builder db@Database{..} keys = do+ -- Things that I need to force before my results are ready+ toForce <- liftIO $ newIORef []++ results <- withLockAIO databaseLock $ do+ flip traverse keys $ \idKey -> do+ -- Resolve the id+ id <- case idKey of+ Left id -> pure id+ Right key -> liftIO $ do+ ids <- readIORef databaseIds+ case Intern.lookup key ids of+ Just v -> pure v+ Nothing -> do+ (ids, id) <- pure $ Intern.add key ids+ writeIORef' databaseIds ids+ return id++ -- Spawn the id if needed+ status <- liftIO $ Ids.lookup databaseValues id+ val <- case fromMaybe (fromRight undefined idKey, Dirty Nothing) status of+ (_, Clean r) -> pure r+ (_, Running force val _) -> do+ liftIO $ modifyIORef toForce (Wait force :)+ pure val+ (key, Dirty s) -> do+ act <- unliftAIO (refresh db key id s)+ let (force, val) = splitIO (join act)+ liftIO $ Ids.insert databaseValues id (key, Running force val s)+ liftIO $ modifyIORef toForce (Spawn force:)+ pure val++ pure (id, val)++ toForceList <- liftIO $ readIORef toForce+ waitAll <- unliftAIO $ mapConcurrentlyAIO_ id toForceList+ case toForceList of+ [] -> return $ Left results+ _ -> return $ Right $ do+ waitAll+ pure results++-- | Refresh a key:+-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.+-- This assumes that the implementation will be a lookup+-- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself+refresh :: Database -> Key -> Id -> Maybe Result -> AIO (IO Result)+refresh db key id result@(Just me@Result{resultDeps = ResultDeps deps}) = do+ res <- builder db $ map Left deps+ case res of+ Left res ->+ if isDirty res+ then asyncWithCleanUp $ liftIO $ compute db key id RunDependenciesChanged result+ else pure $ compute db key id RunDependenciesSame result+ Right iores -> asyncWithCleanUp $ liftIO $ do+ res <- iores+ let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame+ compute db key id mode result+ where+ isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)++refresh db key id result =+ asyncWithCleanUp $ liftIO $ compute db key id RunDependenciesChanged result+++-- | Compute a key.+compute :: Database -> Key -> Id -> RunMode -> Maybe Result -> IO Result+compute db@Database{..} key id mode result = do+ let act = runRule databaseRules key (fmap resultData result) mode+ deps <- newIORef UnknownDeps+ (execution, RunResult{..}) <-+ duration $ runReaderT (fromAction act) $ SAction db deps+ built <- readIORef databaseStep+ deps <- readIORef deps+ let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result+ built' = if runChanged /= ChangedNothing then built else changed+ -- only update the deps when the rule ran with changes+ actualDeps = if runChanged /= ChangedNothing then deps else previousDeps+ previousDeps= maybe UnknownDeps resultDeps result+ let res = Result runValue built' changed built actualDeps execution runStore+ case getResultDepsDefault [] actualDeps of+ deps | not(null deps)+ && runChanged /= ChangedNothing+ -> do+ void $ forkIO $+ updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps)+ _ -> pure ()+ withLock databaseLock $+ Ids.insert databaseValues id (key, Clean res)+ pure res++-- | Returns the set of dirty keys annotated with their age (in # of builds)+getDirtySet :: Database -> IO [(Id,(Key, Int))]+getDirtySet db = do+ Step curr <- readIORef (databaseStep db)+ dbContents <- Ids.toList (databaseValues db)+ let calcAge Result{resultBuilt = Step x} = curr - x+ calcAgeStatus (Dirty x)=calcAge <$> x+ calcAgeStatus _ = Nothing+ return $ mapMaybe ((secondM.secondM) calcAgeStatus) dbContents++-- | Returns ann approximation of the database keys,+-- annotated with how long ago (in # builds) they were visited+getKeysAndVisitAge :: Database -> IO [(Key, Int)]+getKeysAndVisitAge db = do+ values <- Ids.elems (databaseValues db)+ Step curr <- readIORef (databaseStep db)+ let keysWithVisitAge = mapMaybe (secondM (fmap getAge . getResult)) values+ getAge Result{resultVisited = Step s} = curr - s+ return keysWithVisitAge+--------------------------------------------------------------------------------+-- Lazy IO trick++data Box a = Box {fromBox :: a}++-- | Split an IO computation into an unsafe lazy value and a forcing computation+splitIO :: IO a -> (IO (), a)+splitIO act = do+ let act2 = Box <$> act+ let res = unsafePerformIO act2+ (void $ evaluate res, fromBox res)++--------------------------------------------------------------------------------+-- Reverse dependencies++-- | Update the reverse dependencies of an Id+updateReverseDeps+ :: Id -- ^ Id+ -> Database+ -> [Id] -- ^ Previous direct dependencies of Id+ -> IntSet -- ^ Current direct dependencies of Id+ -> IO ()+updateReverseDeps myId db prev new = withLock (databaseReverseDepsLock db) $ uninterruptibleMask_ $ do+ forM_ prev $ \d ->+ unless (d `Set.member` new) $+ doOne (Set.delete myId) d+ forM_ (Set.elems new) $+ doOne (Set.insert myId)+ where+ doOne f id = do+ rdeps <- getReverseDependencies db id+ Ids.insert (databaseReverseDeps db) id (f $ fromMaybe mempty rdeps)++getReverseDependencies :: Database -> Id -> IO (Maybe (IntSet))+getReverseDependencies db = Ids.lookup (databaseReverseDeps db)++transitiveDirtySet :: Foldable t => Database -> t Id -> IO IntSet+transitiveDirtySet database = flip State.execStateT Set.empty . traverse_ loop+ where+ loop x = do+ seen <- State.get+ if x `Set.member` seen then pure () else do+ State.put (Set.insert x seen)+ next <- lift $ getReverseDependencies database x+ traverse_ loop (maybe mempty Set.toList next)++-- | IO extended to track created asyncs to clean them up when the thread is killed,+-- generalizing 'withAsync'+newtype AIO a = AIO { unAIO :: ReaderT (IORef [Async ()]) IO a }+ deriving newtype (Applicative, Functor, Monad, MonadIO)++runAIO :: AIO a -> IO a+runAIO (AIO act) = do+ asyncs <- newIORef []+ runReaderT act asyncs `onException` cleanupAsync asyncs++asyncWithCleanUp :: AIO a -> AIO (IO a)+asyncWithCleanUp act = do+ st <- AIO ask+ io <- unliftAIO act+ liftIO $ uninterruptibleMask $ \restore -> do+ a <- async $ restore io+ atomicModifyIORef'_ st (void a :)+ return $ wait a++withLockAIO :: Lock -> AIO a -> AIO a+withLockAIO lock act = do+ io <- unliftAIO act+ liftIO $ withLock lock io++unliftAIO :: AIO a -> AIO (IO a)+unliftAIO act = do+ st <- AIO ask+ return $ runReaderT (unAIO act) st++cleanupAsync :: IORef [Async a] -> IO ()+cleanupAsync ref = uninterruptibleMask_ $ do+ asyncs <- readIORef ref+ mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs+ mapM_ waitCatch asyncs++data Wait a+ = Wait {justWait :: !a}+ | Spawn {justWait :: !a}+ deriving Functor++waitOrSpawn :: Wait (IO a) -> IO (Either (IO a) (Async a))+waitOrSpawn (Wait io) = pure $ Left io+waitOrSpawn (Spawn io) = Right <$> async io++mapConcurrentlyAIO_ :: (a -> IO ()) -> [Wait a] -> AIO ()+mapConcurrentlyAIO_ _ [] = pure ()+mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one+mapConcurrentlyAIO_ f many = do+ ref <- AIO ask+ waits <- liftIO $ uninterruptibleMask $ \restore -> do+ waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many+ let asyncs = rights waits+ liftIO $ atomicModifyIORef'_ ref (asyncs ++)+ return waits+ liftIO $ traverse_ (either id wait) waits
+ src/Development/IDE/Graph/Internal/Ids.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnboxedTuples #-}++-- Note that argument order is more like IORef than Map, because its mutable+module Development.IDE.Graph.Internal.Ids(+ Ids, Id,+ empty, insert, lookup, fromList,+ null, size, sizeUpperBound,+ forWithKeyM_, forCopy, forMutate,+ toList, elems, toMap+ ) where++import Control.Exception+import Control.Monad.Extra+import Data.Functor+import qualified Data.HashMap.Strict as Map+import Data.IORef.Extra+import Data.List.Extra (zipFrom)+import Data.Maybe+import Data.Primitive.Array hiding (fromList)+import Development.IDE.Graph.Internal.Intern (Id)+import GHC.Exts (RealWorld)+import GHC.IO (IO (..))+import Prelude hiding (lookup, null)+++newtype Ids a = Ids (IORef (S a))++data S a = S+ {capacity :: {-# UNPACK #-} !Int -- ^ Number of entries in values, initially 0+ ,used :: {-# UNPACK #-} !Int -- ^ Capacity that has been used, assuming no gaps from index 0, initially 0+ ,values :: {-# UNPACK #-} !(MutableArray RealWorld (Maybe a))+ }+++empty :: IO (Ids a)+empty = do+ let capacity = 0+ let used = 0+ values <- newArray capacity Nothing+ Ids <$> newIORef S{..}++fromList :: [a] -> IO (Ids a)+fromList xs = do+ let capacity = length xs+ let used = capacity+ values <- newArray capacity Nothing+ forM_ (zipFrom 0 xs) $ \(i, x) ->+ writeArray values i $ Just x+ Ids <$> newIORef S{..}++sizeUpperBound :: Ids a -> IO Int+sizeUpperBound (Ids ref) = do+ S{..} <- readIORef ref+ pure used+++size :: Ids a -> IO Int+size (Ids ref) = do+ S{..} <- readIORef ref+ let go !acc i+ | i < 0 = pure acc+ | otherwise = do+ v <- readArray values i+ if isJust v then go (acc+1) (i-1) else go acc (i-1)+ go 0 (used-1)+++toMap :: Ids a -> IO (Map.HashMap Id a)+toMap ids = do+ mp <- Map.fromList <$> toListUnsafe ids+ pure $! mp++forWithKeyM_ :: Ids a -> (Id -> a -> IO ()) -> IO ()+forWithKeyM_ (Ids ref) f = do+ S{..} <- readIORef ref+ let go !i | i >= used = pure ()+ | otherwise = do+ v <- readArray values i+ whenJust v $ f $ fromIntegral i+ go $ i+1+ go 0++forCopy :: Ids a -> (a -> b) -> IO (Ids b)+forCopy (Ids ref) f = do+ S{..} <- readIORef ref+ values2 <- newArray capacity Nothing+ let go !i | i >= used = pure ()+ | otherwise = do+ v <- readArray values i+ whenJust v $ \v -> writeArray values2 i $ Just $ f v+ go $ i+1+ go 0+ Ids <$> newIORef (S capacity used values2)+++forMutate :: Ids a -> (Id -> a -> a) -> IO ()+forMutate (Ids ref) f = do+ S{..} <- readIORef ref+ let go !i | i >= used = pure ()+ | otherwise = do+ v <- readArray values i+ whenJust v $ \v -> writeArray values i $! Just $! f i v+ go $ i+1+ go 0+++toListUnsafe :: Ids a -> IO [(Id, a)]+toListUnsafe (Ids ref) = do+ S{..} <- readIORef ref++ -- execute in O(1) stack+ -- see https://neilmitchell.blogspot.co.uk/2015/09/making-sequencemapm-for-io-take-o1-stack.html+ let index _ i | i >= used = []+ index r i | IO io <- readArray values i = case io r of+ (# r, Nothing #) -> index r (i+1)+ (# r, Just v #) -> (fromIntegral i, v) : index r (i+1)++ IO $ \r -> (# r, index r 0 #)+++toList :: Ids a -> IO [(Id, a)]+toList ids = do+ xs <- toListUnsafe ids+ let demand (_:xs) = demand xs+ demand [] = ()+ evaluate $ demand xs+ pure xs++elems :: Ids a -> IO [a]+elems ids = map snd <$> toList ids++null :: Ids a -> IO Bool+null ids = (== 0) <$> sizeUpperBound ids+++insert :: Ids a -> Id -> a -> IO ()+insert (Ids ref) (i) v = do+ S{..} <- readIORef ref+ let ii = fromIntegral i+ if ii < capacity then do+ writeArray values ii $ Just v+ when (ii >= used) $ writeIORef' ref S{used=ii+1,..}+ else do+ c2<- pure $ max (capacity * 2) (ii + 10000)+ v2 <- newArray c2 Nothing+ copyMutableArray v2 0 values 0 capacity+ writeArray v2 ii $ Just v+ writeIORef' ref $ S c2 (ii+1) v2++lookup :: Ids a -> Id -> IO (Maybe a)+lookup (Ids ref) (i) = do+ S{..} <- readIORef ref+ let ii = fromIntegral i+ if ii < used then+ readArray values ii+ else+ pure Nothing
+ src/Development/IDE/Graph/Internal/Intern.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Development.IDE.Graph.Internal.Intern(+ Intern, Id,+ empty, insert, add, lookup, toList, fromList+ ) where++import qualified Data.HashMap.Strict as Map+import Data.List (foldl')+import Development.IDE.Graph.Classes+import Prelude hiding (lookup)+++-- Invariant: The first field is the highest value in the Map+data Intern a = Intern {-# UNPACK #-} !Int !(Map.HashMap a Id)++type Id = Int++empty :: Intern a+empty = Intern 0 Map.empty+++insert :: (Eq a, Hashable a) => a -> Id -> Intern a -> Intern a+insert k v (Intern n mp) = Intern (max n v) $ Map.insert k v mp+++add :: (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)+add k (Intern v mp) = (Intern v2 $ Map.insert k v2 mp, v2)+ where v2 = v + 1+++lookup :: (Eq a, Hashable a) => a -> Intern a -> Maybe Id+lookup k (Intern _ mp) = Map.lookup k mp+++toList :: Intern a -> [(a, Id)]+toList (Intern _ mp) = Map.toList mp+++fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a+fromList xs = Intern (foldl' max 0 [i | (_, i) <- xs]) (Map.fromList xs)
src/Development/IDE/Graph/Internal/Options.hs view
@@ -2,13 +2,12 @@ module Development.IDE.Graph.Internal.Options where +import Control.Monad.Trans.Reader import Data.Dynamic-import qualified Data.HashMap.Strict as Map-import Development.IDE.Graph.Internal.Action-import Development.IDE.Graph.Internal.Rules-import qualified Development.Shake as Shake+import Development.IDE.Graph.Internal.Types data ShakeOptions = ShakeOptions {+ -- | Has no effect, kept only for api compatibility with Shake shakeThreads :: Int, shakeFiles :: FilePath, shakeExtra :: Maybe Dynamic,@@ -19,22 +18,15 @@ 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+getShakeExtra = do+ extra <- Action $ asks $ databaseExtra . actionDatabase+ pure $ fromDynamic extra getShakeExtraRules :: Typeable a => Rules (Maybe a)-getShakeExtraRules = Rules Shake.getShakeExtraRules+getShakeExtraRules = do+ extra <- Rules $ asks rulesExtra+ pure $ fromDynamic extra newShakeExtra :: Typeable a => a -> Maybe Dynamic newShakeExtra = Just . toDyn
+ src/Development/IDE/Graph/Internal/Paths.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Development.IDE.Graph.Internal.Paths (getDataFile) where++import Paths_hls_graph++#ifndef FILE_EMBED+import Control.Exception (SomeException (SomeException), catch)+import Control.Monad (filterM)+import System.Directory (doesFileExist, getCurrentDirectory)+import System.Environment (getExecutablePath)+import System.FilePath (takeDirectory, (</>))+import System.IO.Unsafe (unsafePerformIO)+#endif++#ifdef FILE_EMBED+import qualified Data.ByteString as BS+import qualified Data.ByteString as LBS+import Data.FileEmbed++initDataDirectory :: IO ()+initDataDirectory = pure ()++htmlDataFiles :: [(FilePath, BS.ByteString)]+htmlDataFiles =+ [ ("profile.html", $(embedFile "html/profile.html"))+ , ("progress.html", $(embedFile "html/progress.html"))+ , ("shake.js", $(embedFile "html/shake.js"))+ ]++readDataFileHTML :: FilePath -> IO LBS.ByteString+readDataFileHTML file = do+ case lookup file htmlDataFiles of+ Nothing -> fail $ "Could not find data file " ++ file ++ " in embedded data files!"+ Just x -> pure (LBS.fromStrict x)++manualDirData :: [(FilePath, BS.ByteString)]+manualDirData = $(embedDir "docs/manual")++hasManualData :: IO Bool+hasManualData = pure True++copyManualData :: FilePath -> IO ()+copyManualData dest = do+ createDirectoryRecursive dest+ forM_ manualDirData $ \(file, bs) -> do+ BS.writeFile (dest </> file) bs++#else+-- We want getDataFileName to be relative to the current directory on program startup,+-- even if we issue a change directory command. Therefore, first call caches, future ones read.++{-# NOINLINE dataDirs #-}+dataDirs :: [String]+dataDirs = unsafePerformIO $ do+ datdir <- getDataDir+ exedir <- takeDirectory <$> getExecutablePath `catch` \SomeException{} -> pure ""+ curdir <- getCurrentDirectory+ pure $ [datdir] ++ [exedir | exedir /= ""] ++ [curdir]+++getDataFile :: FilePath -> IO FilePath+getDataFile file = do+ let poss = map (</> file) dataDirs+ res <- filterM doesFileExist poss+ case res of+ [] -> fail $ unlines $ ("Could not find data file " ++ file ++ ", looked in:") : map (" " ++) poss+ x:_ -> pure x++#endif
+ src/Development/IDE/Graph/Internal/Profile.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++{- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion++module Development.IDE.Graph.Internal.Profile (writeProfile) where++import Data.Bifunctor+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Char+import Data.Dynamic (toDyn)+import qualified Data.HashMap.Strict as Map+import Data.IORef+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as Set+import Data.List (dropWhileEnd, foldl',+ intercalate,+ partition, sort,+ sortBy)+import Data.List.Extra (nubOrd)+import Data.Maybe+import Data.Time (defaultTimeLocale,+ formatTime,+ getCurrentTime,+ iso8601DateFormat)+import Development.IDE.Graph.Classes+import Development.IDE.Graph.Internal.Database (getDirtySet)+import qualified Development.IDE.Graph.Internal.Ids as Ids+import Development.IDE.Graph.Internal.Paths+import Development.IDE.Graph.Internal.Types+import qualified Language.Javascript.DGTable as DGTable+import qualified Language.Javascript.Flot as Flot+import qualified Language.Javascript.JQuery as JQuery+import Numeric.Extra (showDP)+import System.FilePath+import System.IO.Unsafe (unsafePerformIO)+import System.Time.Extra (Seconds)++#ifdef FILE_EMBED+import Data.FileEmbed+import Language.Haskell.TH.Syntax (runIO)+#endif++-- | Generates an report given some build system profiling data.+writeProfile :: FilePath -> Database -> IO ()+writeProfile out db = do+ (report, mapping) <- toReport db+ dirtyKeysMapped <- do+ dirtyIds <- Set.fromList . fmap fst <$> getDirtySet db+ let dirtyKeysMapped = mapMaybe (`IntMap.lookup` mapping) . Set.toList $ dirtyIds+ return $ Just $ sort dirtyKeysMapped+ rpt <- generateHTML dirtyKeysMapped report+ LBS.writeFile out rpt++data ProfileEntry = ProfileEntry+ {prfName :: !String, prfBuilt :: !Int, prfChanged :: !Int, prfVisited :: !Int, prfDepends :: [[Int]], prfExecution :: !Seconds}++-- | Eliminate all errors from the database, pretending they don't exist+-- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value))+resultsOnly :: [(Ids.Id, (k, Status))] -> Map.HashMap Ids.Id (k, Result)+resultsOnly mp = Map.map (fmap (\r ->+ r{resultDeps = mapResultDeps (filter (isJust . flip Map.lookup keep)) $ resultDeps r}+ )) keep+ where+ keep = Map.fromList $ mapMaybe ((traverse.traverse) getResult) mp++-- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such+-- that no item points to an item before itself.+-- Raise an error if you end up with a cycle.+dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a]+-- Algorithm:+-- Divide everyone up into those who have no dependencies [Id]+-- And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])]+-- Where d :-> Just (k, ds), k depends on firstly d, then remaining on ds+-- For each with no dependencies, add to list, then take its dep hole and+-- promote them either to Nothing (if ds == []) or into a new slot.+-- k :-> Nothing means the key has already been freed+dependencyOrder shw status =+ f (map fst noDeps) $+ Map.map Just $+ Map.fromListWith (++)+ [(d, [(k,ds)]) | (k,d:ds) <- hasDeps]+ where+ (noDeps, hasDeps) = partition (null . snd) status++ f [] mp | null bad = []+ | otherwise = error $ unlines $+ "Internal invariant broken, database seems to be cyclic" :+ map (" " ++) bad +++ ["... plus " ++ show (length badOverflow) ++ " more ..." | not $ null badOverflow]+ where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- Map.toList mp]++ f (x:xs) mp = x : f (now++xs) later+ where Just free = Map.lookupDefault (Just []) x mp+ (now,later) = foldl' g ([], Map.insert x Nothing mp) free++ g (free, mp) (k, []) = (k:free, mp)+ g (free, mp) (k, d:ds) = case Map.lookupDefault (Just []) d mp of+ Nothing -> g (free, mp) (k, ds)+ Just todo -> (free, Map.insert d (Just $ (k,ds) : todo) mp)++prepareForDependencyOrder :: Database -> IO (Map.HashMap Ids.Id (Key, Result))+prepareForDependencyOrder db = do+ current <- readIORef $ databaseStep db+ Map.insert (-1) (Key "alwaysRerun", alwaysRerunResult current) . resultsOnly+ <$> Ids.toList (databaseValues db)++-- | Returns a list of profile entries, and a mapping linking a non-error Id to its profile entry+toReport :: Database -> IO ([ProfileEntry], IntMap Int)+toReport db = do+ status <- prepareForDependencyOrder db+ let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status+ in dependencyOrder shw+ $ map (second (getResultDepsDefault [-1] . resultDeps . snd))+ $ Map.toList status+ ids = IntMap.fromList $ zip order [0..]++ steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | (_k, Result{..}) <- Map.elems status]++ in Map.fromList $ zip (sortBy (flip compare) xs) [0..]++ f (k, Result{..}) = ProfileEntry+ {prfName = show k+ ,prfBuilt = fromStep resultBuilt+ ,prfVisited = fromStep resultVisited+ ,prfChanged = fromStep resultChanged+ ,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ getResultDepsDefault [-1] resultDeps+ ,prfExecution = resultExecution+ }+ where fromStep i = fromJust $ Map.lookup i steps+ pure ([maybe (error "toReport") f $ Map.lookup i status | i <- order], ids)++alwaysRerunResult :: Step -> Result+alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps []) 0 mempty++readDataFileHTML :: FilePath -> IO LBS.ByteString+readDataFileHTML file = LBS.readFile =<< getDataFile ("html" </> file)++generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO LBS.ByteString+generateHTML dirtyKeys xs = do+ report <- readDataFileHTML "profile.html"+ let f "data/profile-data.js" = pure $ LBS.pack $ "var profile =\n" ++ generateJSONProfile xs+ f "data/build-data.js" = pure $ LBS.pack $ "var build =\n" ++ generateJSONBuild dirtyKeys+ f other = error other+ runTemplate f report++generateJSONBuild :: Maybe [Ids.Id] -> String+generateJSONBuild (Just dirtyKeys) = jsonList [jsonList (map show dirtyKeys)]+generateJSONBuild Nothing = jsonList []++generateJSONProfile :: [ProfileEntry] -> String+generateJSONProfile = jsonListLines . map showEntry+ where+ showEntry ProfileEntry{..} = jsonList $+ [show prfName+ ,showTime prfExecution+ ,show prfBuilt+ ,show prfChanged+ ,show prfVisited+ ] +++ [show prfDepends | not (null prfDepends)]+ showTime x = if '.' `elem` y then dropWhileEnd (== '.') $ dropWhileEnd (== '0') y else y+ where y = showDP 4 x++jsonListLines :: [String] -> String+jsonListLines xs = "[" ++ intercalate "\n," xs ++ "\n]"++jsonList :: [String] -> String+jsonList xs = "[" ++ intercalate "," xs ++ "]"++-- Very hard to abstract over TH, so we do it with CPP+#ifdef FILE_EMBED+#define FILE(x) (pure (LBS.fromStrict $(embedFile =<< runIO (x))))+#else+#define FILE(x) (LBS.readFile =<< (x))+#endif++libraries :: [(String, IO LBS.ByteString)]+libraries =+ [("jquery.js", FILE(JQuery.file))+ ,("jquery.dgtable.js", FILE(DGTable.file))+ ,("jquery.flot.js", FILE(Flot.file Flot.Flot))+ ,("jquery.flot.stack.js", FILE(Flot.file Flot.FlotStack))+ ]+++-- | Template Engine. Perform the following replacements on a line basis:+--+-- * <script src="foo"></script> ==> <script>[[foo]]</script>+--+-- * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>+runTemplate :: (FilePath -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString+runTemplate ask = lbsMapLinesIO f+ where+ link = LBS.pack "<link href=\""+ script = LBS.pack "<script src=\""++ f x | Just file <- LBS.stripPrefix script y = do res <- grab file; pure $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"+ | Just file <- LBS.stripPrefix link y = do res <- grab file; pure $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>"+ | otherwise = pure x+ where+ y = LBS.dropWhile isSpace x+ grab = asker . takeWhile (/= '\"') . LBS.unpack++ asker o@(splitFileName -> ("lib/",x)) =+ case lookup x libraries of+ Nothing -> error $ "Template library, unknown library: " ++ o+ Just act -> act++ asker "shake.js" = readDataFileHTML "shake.js"+ asker "data/metadata.js" = do+ time <- getCurrentTime+ pure $ LBS.pack $+ "var version = \"0\"" +++ "\nvar generated = " ++ show (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) time)+ asker x = ask x++-- Perform a mapM on each line and put the result back together again+lbsMapLinesIO :: (LBS.ByteString -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString+-- If we do the obvious @fmap LBS.unlines . mapM f@ then all the monadic actions are run on all the lines+-- before it starts producing the lazy result, killing streaming and having more stack usage.+-- The real solution (albeit with too many dependencies for something small) is a streaming library,+-- but a little bit of unsafePerformIO does the trick too.+lbsMapLinesIO f = pure . LBS.unlines . map (unsafePerformIO . f) . LBS.lines
src/Development/IDE/Graph/Internal/Rules.hs view
@@ -1,24 +1,60 @@+-- We deliberately want to ensure the function we add to the rule database+-- has the constraints we need on it when we get it out.+{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-} module Development.IDE.Graph.Internal.Rules where -import Control.Monad.Fail-import Control.Monad.IO.Class-import qualified Data.ByteString as BS-import Development.IDE.Graph.Internal.Action-import qualified Development.Shake as Shake-import Development.Shake.Classes-import qualified Development.Shake.Rule as Shake+import Development.IDE.Graph.Classes+import Control.Exception.Extra+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.ByteString as BS+import Data.Dynamic+import Data.Typeable+import Data.IORef+import qualified Data.HashMap.Strict as Map+import Control.Monad.Trans.Reader+import Development.IDE.Graph.Internal.Types+import Data.Maybe -newtype Rules a = Rules {fromRules :: Shake.Rules a}- deriving (Monoid, Semigroup, Monad, Applicative, Functor, MonadIO, MonadFail)+-- | The type mapping between the @key@ or a rule and the resulting @value@.+-- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'.+type family RuleResult key -- = value action :: Action a -> Rules ()-action = Rules . Shake.action . fromAction+action x = do+ ref <- Rules $ asks rulesActions+ liftIO $ modifyIORef' ref (void x:) addRule- :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value, NFData value, Show value)- => (key -> Maybe BS.ByteString -> Shake.RunMode -> Action (Shake.RunResult value))+ :: forall key value .+ (RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value)+ => (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value)) -> Rules ()-addRule f = Rules $ Shake.addBuiltinRule Shake.noLint Shake.noIdentity $ \k bs r -> fromAction $ f k bs r+addRule f = do+ ref <- Rules $ asks rulesMap+ liftIO $ modifyIORef' ref $ Map.insert (typeRep (Proxy :: Proxy key)) (toDyn f2)+ where+ f2 :: Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)+ f2 (Key a) b c = do+ v <- f (fromJust $ cast a :: key) b c+ v <- liftIO $ evaluate v+ pure $ (Value . toDyn) <$> v++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"+ Just x -> unwrapDynamic x key bs mode++runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])+runRules rulesExtra (Rules rules) = do+ rulesActions <- newIORef []+ rulesMap <- newIORef Map.empty+ runReaderT rules SRules{..}+ (,) <$> readIORef rulesMap <*> readIORef rulesActions
+ src/Development/IDE/Graph/Internal/Types.hs view
@@ -0,0 +1,184 @@+++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Development.IDE.Graph.Internal.Types where++import Control.Applicative+import Control.Concurrent.Extra+import Control.Monad.Catch+-- Needed in GHC 8.6.5+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.ByteString as BS+import Data.Dynamic+import qualified Data.HashMap.Strict as Map+import Data.IORef+import Data.IntSet (IntSet)+import Data.Maybe+import Data.Typeable+import Development.IDE.Graph.Classes+import Development.IDE.Graph.Internal.Ids+import Development.IDE.Graph.Internal.Intern+import GHC.Generics (Generic)+import System.Time.Extra (Seconds)+++unwrapDynamic :: forall a . Typeable a => Dynamic -> a+unwrapDynamic x = fromMaybe (error msg) $ fromDynamic x+ where msg = "unwrapDynamic failed: Expected " ++ show (typeRep (Proxy :: Proxy a)) +++ ", but got " ++ show (dynTypeRep x)++---------------------------------------------------------------------+-- RULES++type TheRules = Map.HashMap TypeRep Dynamic++newtype Rules a = Rules (ReaderT SRules IO a)+ deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail)++data SRules = SRules {+ rulesExtra :: !Dynamic,+ rulesActions :: !(IORef [Action ()]),+ rulesMap :: !(IORef TheRules)+ }+++---------------------------------------------------------------------+-- ACTIONS++newtype Action a = Action {fromAction :: ReaderT SAction IO a}+ deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)++data SAction = SAction {+ actionDatabase :: !Database,+ actionDeps :: !(IORef ResultDeps)+ }++getDatabase :: Action Database+getDatabase = Action $ asks actionDatabase++---------------------------------------------------------------------+-- DATABASE++newtype Step = Step Int+ deriving newtype (Eq,Ord,Hashable)++data Key = forall a . (Typeable a, Eq a, Hashable a, Show a) => Key a++instance Eq Key where+ Key a == Key b = Just a == cast b++instance Hashable Key where+ hashWithSalt i (Key x) = hashWithSalt i (typeOf x, x)++instance Show Key where+ show (Key x) = show x++newtype Value = Value Dynamic++data Database = Database {+ databaseExtra :: Dynamic,+ databaseRules :: TheRules,+ databaseStep :: !(IORef Step),+ -- Hold the lock while mutating Ids/Values+ databaseLock :: !Lock,+ databaseIds :: !(IORef (Intern Key)),+ databaseValues :: !(Ids (Key, Status)),+ databaseReverseDeps :: !(Ids IntSet),+ databaseReverseDepsLock :: !Lock+ }++data Status+ = Clean Result+ | Dirty (Maybe Result)+ | Running (IO ()) Result (Maybe Result)++getResult :: Status -> Maybe Result+getResult (Clean re) = Just re+getResult (Dirty m_re) = m_re+getResult (Running _ _ m_re) = m_re++data Result = Result {+ resultValue :: !Value,+ resultBuilt :: !Step, -- ^ the step when it was last recomputed+ resultChanged :: !Step, -- ^ the step when it last changed+ resultVisited :: !Step, -- ^ the step when it was last looked up+ resultDeps :: !ResultDeps,+ resultExecution :: !Seconds, -- ^ How long it took, last time it ran+ resultData :: BS.ByteString+ }++data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Id] | ResultDeps ![Id]++getResultDepsDefault :: [Id] -> ResultDeps -> [Id]+getResultDepsDefault _ (ResultDeps ids) = ids+getResultDepsDefault _ (AlwaysRerunDeps ids) = ids+getResultDepsDefault def UnknownDeps = def++mapResultDeps :: ([Id] -> [Id]) -> ResultDeps -> ResultDeps+mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids+mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids+mapResultDeps _ UnknownDeps = UnknownDeps++instance Semigroup ResultDeps where+ UnknownDeps <> x = x+ x <> UnknownDeps = x+ AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault [] x)+ x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault [] x <> ids)+ ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids')++instance Monoid ResultDeps where+ mempty = UnknownDeps++---------------------------------------------------------------------+-- Running builds++-- | What mode a rule is running in, passed as an argument to 'BuiltinRun'.+data RunMode+ = RunDependenciesSame -- ^ My dependencies have not changed.+ | RunDependenciesChanged -- ^ At least one of my dependencies from last time have changed, or I have no recorded dependencies.+ deriving (Eq,Show)++instance NFData RunMode where rnf x = x `seq` ()++-- | How the output of a rule has changed.+data RunChanged+ = ChangedNothing -- ^ Nothing has changed.+ | ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely).+ | ChangedRecomputeSame -- ^ I recomputed the value and it was the same.+ | ChangedRecomputeDiff -- ^ I recomputed the value and it was different.+ deriving (Eq,Show,Generic)+ deriving anyclass (FromJSON, ToJSON)++instance NFData RunChanged where rnf x = x `seq` ()++-- | The result of 'BuiltinRun'.+data RunResult value = RunResult+ {runChanged :: RunChanged+ -- ^ How has the 'RunResult' changed from what happened last time.+ ,runStore :: BS.ByteString+ -- ^ The value to store in the Shake database.+ ,runValue :: value+ -- ^ The value to return from 'Development.Shake.Rule.apply'.+ } deriving Functor++instance NFData value => NFData (RunResult value) where+ rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3++---------------------------------------------------------------------+-- INSTANCES++instance Semigroup a => Semigroup (Rules a) where+ a <> b = liftA2 (<>) a b++instance Monoid a => Monoid (Rules a) where+ mempty = pure mempty
src/Development/IDE/Graph/Rule.hs view
@@ -4,7 +4,7 @@ -- * Defining builtin rules -- | Functions and types for defining new types of Shake rules. addRule,- Shake.RunMode(..), Shake.RunChanged(..), Shake.RunResult(..),+ RunMode(..), RunChanged(..), RunResult(..), -- * Calling builtin rules -- | Wrappers around calling Shake rules. In general these should be specialised to a builtin rule. apply, apply1,@@ -12,4 +12,4 @@ import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Rules-import qualified Development.Shake.Rule as Shake+import Development.IDE.Graph.Internal.Types