{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Laminar
-- Copyright   :  (c) Dheemanth Manur 2022
-- License     :  MIT (see the file LICENSE)
--
-- Maintainer  :  Dheemanth Manur <dheemanthmanur72@gmail.com>
-- Stability   :  experimental
--
-- This module provides a set of operations for running set of IO actions with
-- dependencies asynchronously.
-- The basic type is @'Task'@ which represents an IO action with a name and dependency list.
-- functions @'buildGraph'@ and @'runGraph'@ used to build and run @'TaskGraph'@ simultanouesly.
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)

-- | Container for all the details required for a Task
data Task = Task
  { -- | Text to uniquely identify a Task
    Task -> Text
taskName :: Text,
    -- | List of dependent Task names
    Task -> [Text]
taskDeps :: [Text],
    -- | IO Action that will be executed
    Task -> IO ()
taskAction :: IO ()
  }

-- | Container for the dependency graph and task list
data TaskGraph = TaskGraph
  { -- | Dependency Map of every task to it's dependency list
    TaskGraph -> Map Text [Text]
graph :: Map Text [Text],
    -- | List of tasks
    TaskGraph -> [Task]
tasks :: [Task]
  }

-- Creating Taskgraphs

-- | Create a @'TaskGraph'@ from a list of @'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)

-- Running TaskGraphs

-- | Execute a @'TaskGraph'@. Any Exceptions thrown by the tasks will be rethrown.
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

-- utils

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

-- test data

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