{-# LANGUAGE OverloadedStrings #-}
module Laminar (Task (..), TaskGraph (..), buildGraph, runGraph) where
import Control.Concurrent (MVar, putMVar, takeMVar, threadDelay)
import Control.Concurrent.Async (Async, async, waitAny)
import Data.List (delete)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import System.Random (randomRIO)
data Task = Task
{
Task -> Text
taskName :: Text,
Task -> [Text]
taskDeps :: [Text],
Task -> IO ()
taskAction :: IO ()
}
data TaskGraph = TaskGraph
{
TaskGraph -> Map Text [Text]
graph :: Map Text [Text],
TaskGraph -> [Task]
tasks :: [Task]
}
buildGraph :: [Task] -> TaskGraph
buildGraph :: [Task] -> TaskGraph
buildGraph [Task]
ts = TaskGraph {graph :: Map Text [Text]
graph = Map Text [Text]
taskGraph, tasks :: [Task]
tasks = [Task]
ts}
where
taskGraph :: Map Text [Text]
taskGraph = [(Text, [Text])] -> Map Text [Text]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, [Text])] -> Map Text [Text])
-> [(Text, [Text])] -> Map Text [Text]
forall a b. (a -> b) -> a -> b
$ (Task -> (Text, [Text])) -> [Task] -> [(Text, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map (\Task
x -> (Task -> Text
taskName Task
x, Task -> [Text]
taskDeps Task
x)) [Task]
ts
taskByName :: TaskGraph -> Text -> Task
taskByName :: TaskGraph -> Text -> Task
taskByName TaskGraph
tg Text
n = [Task] -> Task
forall a. HasCallStack => [a] -> a
head ([Task] -> Task) -> [Task] -> Task
forall a b. (a -> b) -> a -> b
$ (Task -> Bool) -> [Task] -> [Task]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Task
x -> Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Task -> Text
taskName Task
x) (TaskGraph -> [Task]
tasks TaskGraph
tg)
runGraph :: TaskGraph -> IO ()
runGraph :: TaskGraph -> IO ()
runGraph TaskGraph
tg = TaskGraph -> [Async Text] -> IO ()
graphRunner TaskGraph
tg []
graphRunner :: TaskGraph -> [Async Text] -> IO ()
graphRunner :: TaskGraph -> [Async Text] -> IO ()
graphRunner TaskGraph
tg [Async Text]
al =
do
let rt :: [Text]
rt = TaskGraph -> [Text]
runnable TaskGraph
tg
[Async Text]
ar <- (Text -> IO (Async Text)) -> [Text] -> IO [Async Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO Text -> IO (Async Text)
forall a. IO a -> IO (Async a)
async (IO Text -> IO (Async Text))
-> (Text -> IO Text) -> Text -> IO (Async Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> IO Text
runTask (Task -> IO Text) -> (Text -> Task) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaskGraph -> Text -> Task
taskByName TaskGraph
tg) [Text]
rt
let ual :: [Async Text]
ual = [Async Text]
al [Async Text] -> [Async Text] -> [Async Text]
forall a. [a] -> [a] -> [a]
++ [Async Text]
ar
if [Async Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Async Text]
ual
then String -> IO ()
putStrLn String
"No more tasks to run."
else do
(Async Text
t, Text
tn) <- [Async Text] -> IO (Async Text, Text)
forall a. [Async a] -> IO (Async a, a)
waitAny [Async Text]
ual
let utg :: TaskGraph
utg = (TaskGraph -> Text -> TaskGraph)
-> TaskGraph -> [Text] -> TaskGraph
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TaskGraph -> Text -> TaskGraph
updateGraph TaskGraph
tg [Text]
rt
TaskGraph -> [Async Text] -> IO ()
graphRunner TaskGraph
utg (Async Text -> [Async Text] -> [Async Text]
forall a. Eq a => a -> [a] -> [a]
delete Async Text
t [Async Text]
ual)
runTask :: Task -> IO Text
runTask :: Task -> IO Text
runTask Task
t = do
Task -> IO ()
taskAction Task
t
Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Task -> Text
taskName Task
t
updateGraph :: TaskGraph -> Text -> TaskGraph
updateGraph :: TaskGraph -> Text -> TaskGraph
updateGraph (TaskGraph Map Text [Text]
tg [Task]
tl) Text
tn = TaskGraph {graph :: Map Text [Text]
graph = Map Text [Text] -> Map Text [Text]
udg Map Text [Text]
tg, tasks :: [Task]
tasks = [Task]
tl}
where
udg :: Map Text [Text] -> Map Text [Text]
udg = ([Text] -> [Text]) -> Map Text [Text] -> Map Text [Text]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Text -> [Text] -> [Text]
forall a. Eq a => a -> [a] -> [a]
delete Text
tn) (Map Text [Text] -> Map Text [Text])
-> (Map Text [Text] -> Map Text [Text])
-> Map Text [Text]
-> Map Text [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Map Text [Text] -> Map Text [Text]
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
tn
runnable :: TaskGraph -> [Text]
runnable :: TaskGraph -> [Text]
runnable (TaskGraph Map Text [Text]
tg [Task]
_) = Map Text [Text] -> [Text]
forall k a. Map k a -> [k]
Map.keys (Map Text [Text] -> [Text]) -> Map Text [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ ([Text] -> Bool) -> Map Text [Text] -> Map Text [Text]
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text [Text]
tg
putStrLn' :: MVar () -> String -> IO ()
putStrLn' :: MVar () -> String -> IO ()
putStrLn' MVar ()
mvar String
str = do
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
String -> IO ()
putStrLn String
str
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar
taskList :: [Task]
taskList :: [Task]
taskList = [Task
taskA, Task
taskB, Task
taskC, Task
taskD, Task
taskE]
taskA :: Task
taskA :: Task
taskA = Text -> [Text] -> IO () -> Task
Task Text
"A" [] (IO () -> Task) -> IO () -> Task
forall a b. (a -> b) -> a -> b
$ do
IO ()
randomDelay
String -> IO ()
putStrLn String
"Task A Complete."
taskB :: Task
taskB :: Task
taskB = Text -> [Text] -> IO () -> Task
Task Text
"B" [Text
"A"] (IO () -> Task) -> IO () -> Task
forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
10 Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
6)
String -> IO ()
putStrLn String
"Task B Complete."
taskC :: Task
taskC :: Task
taskC = Text -> [Text] -> IO () -> Task
Task Text
"C" [Text
"A"] (IO () -> Task) -> IO () -> Task
forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
10 Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
6)
String -> IO ()
putStrLn String
"Task C Complete."
taskD :: Task
taskD :: Task
taskD = Text -> [Text] -> IO () -> Task
Task Text
"D" [Text
"B"] (IO () -> Task) -> IO () -> Task
forall a b. (a -> b) -> a -> b
$ do
IO ()
randomDelay
String -> IO ()
putStrLn String
"Task D Complete."
taskE :: Task
taskE :: Task
taskE = Text -> [Text] -> IO () -> Task
Task Text
"E" [Text
"D", Text
"C"] (IO () -> Task) -> IO () -> Task
forall a b. (a -> b) -> a -> b
$ do
IO ()
randomDelay
String -> IO ()
putStrLn String
"Task E Complete."
randomDelay :: IO ()
randomDelay :: IO ()
randomDelay = do
(Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
500, Int
5000) IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO ()
threadDelay