{-# LANGUAGE Safe #-}
{-# LANGUAGE TypeFamilies #-}
module Cli.Programs (
CompilerBackend(..),
CxxCommand(..),
TestCommand(..),
TestCommandResult(..),
VersionHash(..),
parallelProcess,
) where
import Control.Concurrent
import Control.Monad (when)
import Control.Monad.IO.Class
import Data.Either (partitionEithers)
import Base.CompilerError
class CompilerBackend b where
type AsyncWait b :: *
syncCxxCommand :: (MonadIO m, CollectErrorsM m) => b -> CxxCommand -> m FilePath
asyncCxxCommand :: (MonadIO m, CollectErrorsM m) => b -> CxxCommand -> m (AsyncWait b)
waitCxxCommand :: (MonadIO m, CollectErrorsM m) => b -> AsyncWait b -> m (Either (AsyncWait b) FilePath)
runTestCommand :: (MonadIO m, CollectErrorsM m) => b -> TestCommand -> m TestCommandResult
getCompilerHash :: (MonadIO m, CollectErrorsM m) => b -> m VersionHash
newtype VersionHash = VersionHash String deriving (VersionHash -> VersionHash -> Bool
(VersionHash -> VersionHash -> Bool)
-> (VersionHash -> VersionHash -> Bool) -> Eq VersionHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionHash -> VersionHash -> Bool
== :: VersionHash -> VersionHash -> Bool
$c/= :: VersionHash -> VersionHash -> Bool
/= :: VersionHash -> VersionHash -> Bool
Eq)
instance Show VersionHash where
show :: VersionHash -> String
show (VersionHash String
h) = String
h
data CxxCommand =
CompileToObject {
CxxCommand -> String
ctoSource :: FilePath,
CxxCommand -> String
ctoPath :: FilePath,
CxxCommand -> [(String, Maybe String)]
ctoMacros :: [(String,Maybe String)],
CxxCommand -> [String]
ctoPaths :: [FilePath],
:: Bool
} |
CompileToShared {
CxxCommand -> [String]
ctsSources :: [FilePath],
CxxCommand -> String
ctsOutput :: FilePath,
CxxCommand -> [String]
ctsLinkFlags :: [String]
} |
CompileToBinary {
CxxCommand -> String
ctbMain :: FilePath,
CxxCommand -> [String]
ctbSources :: [FilePath],
CxxCommand -> [(String, Maybe String)]
ctbMacros :: [(String,Maybe String)],
CxxCommand -> String
ctbOutput :: FilePath,
CxxCommand -> [String]
ctbPaths :: [FilePath],
CxxCommand -> [String]
ctbLinkFlags :: [String]
}
deriving (Int -> CxxCommand -> ShowS
[CxxCommand] -> ShowS
CxxCommand -> String
(Int -> CxxCommand -> ShowS)
-> (CxxCommand -> String)
-> ([CxxCommand] -> ShowS)
-> Show CxxCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CxxCommand -> ShowS
showsPrec :: Int -> CxxCommand -> ShowS
$cshow :: CxxCommand -> String
show :: CxxCommand -> String
$cshowList :: [CxxCommand] -> ShowS
showList :: [CxxCommand] -> ShowS
Show)
data TestCommand =
TestCommand {
TestCommand -> String
tcBinary :: FilePath,
TestCommand -> String
tcPath :: FilePath,
TestCommand -> [String]
tcArgs :: [String]
}
deriving (Int -> TestCommand -> ShowS
[TestCommand] -> ShowS
TestCommand -> String
(Int -> TestCommand -> ShowS)
-> (TestCommand -> String)
-> ([TestCommand] -> ShowS)
-> Show TestCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestCommand -> ShowS
showsPrec :: Int -> TestCommand -> ShowS
$cshow :: TestCommand -> String
show :: TestCommand -> String
$cshowList :: [TestCommand] -> ShowS
showList :: [TestCommand] -> ShowS
Show)
data TestCommandResult =
TestCommandResult {
TestCommandResult -> Bool
tcrSuccess :: Bool,
TestCommandResult -> [String]
tcrOutput :: [String],
TestCommandResult -> [String]
tcrError :: [String]
}
deriving (Int -> TestCommandResult -> ShowS
[TestCommandResult] -> ShowS
TestCommandResult -> String
(Int -> TestCommandResult -> ShowS)
-> (TestCommandResult -> String)
-> ([TestCommandResult] -> ShowS)
-> Show TestCommandResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestCommandResult -> ShowS
showsPrec :: Int -> TestCommandResult -> ShowS
$cshow :: TestCommandResult -> String
show :: TestCommandResult -> String
$cshowList :: [TestCommandResult] -> ShowS
showList :: [TestCommandResult] -> ShowS
Show)
parallelProcess :: (CompilerBackend b, MonadIO m, CollectErrorsM m) =>
b -> Int -> [(m (AsyncWait b),a)] -> m [(FilePath,a)]
parallelProcess :: forall b (m :: * -> *) a.
(CompilerBackend b, MonadIO m, CollectErrorsM m) =>
b -> Int -> [(m (AsyncWait b), a)] -> m [(String, a)]
parallelProcess b
b Int
n [(m (AsyncWait b), a)]
xs | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = b -> Int -> [(m (AsyncWait b), a)] -> m [(String, a)]
forall b (m :: * -> *) a.
(CompilerBackend b, MonadIO m, CollectErrorsM m) =>
b -> Int -> [(m (AsyncWait b), a)] -> m [(String, a)]
parallelProcess b
b Int
1 [(m (AsyncWait b), a)]
xs
parallelProcess b
b Int
n [(m (AsyncWait b), a)]
xs = do
[(AsyncWait b, a)]
now <- ((m (AsyncWait b), a) -> m (AsyncWait b, a))
-> [(m (AsyncWait b), a)] -> m [(AsyncWait b, a)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (m (AsyncWait b), a) -> m (AsyncWait b, a)
forall {m :: * -> *} {a} {b}. Monad m => (m a, b) -> m (a, b)
start ([(m (AsyncWait b), a)] -> m [(AsyncWait b, a)])
-> [(m (AsyncWait b), a)] -> m [(AsyncWait b, a)]
forall a b. (a -> b) -> a -> b
$ Int -> [(m (AsyncWait b), a)] -> [(m (AsyncWait b), a)]
forall a. Int -> [a] -> [a]
take Int
n [(m (AsyncWait b), a)]
xs
let later :: [(m (AsyncWait b), a)]
later = Int -> [(m (AsyncWait b), a)] -> [(m (AsyncWait b), a)]
forall a. Int -> [a] -> [a]
drop Int
n [(m (AsyncWait b), a)]
xs
[(AsyncWait b, a)] -> [(m (AsyncWait b), a)] -> m [(String, a)]
recursive [(AsyncWait b, a)]
now [(m (AsyncWait b), a)]
later where
start :: (m a, b) -> m (a, b)
start (m a
process,b
extra) = do
a
process' <- m a
process
(a, b) -> m (a, b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
process',b
extra)
wait :: (AsyncWait b, a) -> m (Either (AsyncWait b, a) (String, a))
wait (AsyncWait b
process,a
extra) = do
Either (AsyncWait b) String
process' <- b -> AsyncWait b -> m (Either (AsyncWait b) String)
forall b (m :: * -> *).
(CompilerBackend b, MonadIO m, CollectErrorsM m) =>
b -> AsyncWait b -> m (Either (AsyncWait b) String)
forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
b -> AsyncWait b -> m (Either (AsyncWait b) String)
waitCxxCommand b
b AsyncWait b
process
case Either (AsyncWait b) String
process' of
Left AsyncWait b
process2 -> Either (AsyncWait b, a) (String, a)
-> m (Either (AsyncWait b, a) (String, a))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (AsyncWait b, a) (String, a)
-> m (Either (AsyncWait b, a) (String, a)))
-> Either (AsyncWait b, a) (String, a)
-> m (Either (AsyncWait b, a) (String, a))
forall a b. (a -> b) -> a -> b
$ (AsyncWait b, a) -> Either (AsyncWait b, a) (String, a)
forall a b. a -> Either a b
Left (AsyncWait b
process2,a
extra)
Right String
path -> Either (AsyncWait b, a) (String, a)
-> m (Either (AsyncWait b, a) (String, a))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (AsyncWait b, a) (String, a)
-> m (Either (AsyncWait b, a) (String, a)))
-> Either (AsyncWait b, a) (String, a)
-> m (Either (AsyncWait b, a) (String, a))
forall a b. (a -> b) -> a -> b
$ (String, a) -> Either (AsyncWait b, a) (String, a)
forall a b. b -> Either a b
Right (String
path,a
extra)
recursive :: [(AsyncWait b, a)] -> [(m (AsyncWait b), a)] -> m [(String, a)]
recursive [] [(m (AsyncWait b), a)]
_ = [(String, a)] -> m [(String, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
recursive [(AsyncWait b, a)]
now [(m (AsyncWait b), a)]
later = do
[Either (AsyncWait b, a) (String, a)]
tried <- ((AsyncWait b, a) -> m (Either (AsyncWait b, a) (String, a)))
-> [(AsyncWait b, a)] -> m [Either (AsyncWait b, a) (String, a)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (AsyncWait b, a) -> m (Either (AsyncWait b, a) (String, a))
wait [(AsyncWait b, a)]
now
let ([(AsyncWait b, a)]
running,[(String, a)]
done) = [Either (AsyncWait b, a) (String, a)]
-> ([(AsyncWait b, a)], [(String, a)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (AsyncWait b, a) (String, a)]
tried
let k :: Int
k = [(String, a)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, a)]
done
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
10000
[(AsyncWait b, a)]
new <- ((m (AsyncWait b), a) -> m (AsyncWait b, a))
-> [(m (AsyncWait b), a)] -> m [(AsyncWait b, a)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (m (AsyncWait b), a) -> m (AsyncWait b, a)
forall {m :: * -> *} {a} {b}. Monad m => (m a, b) -> m (a, b)
start ([(m (AsyncWait b), a)] -> m [(AsyncWait b, a)])
-> [(m (AsyncWait b), a)] -> m [(AsyncWait b, a)]
forall a b. (a -> b) -> a -> b
$ Int -> [(m (AsyncWait b), a)] -> [(m (AsyncWait b), a)]
forall a. Int -> [a] -> [a]
take Int
k [(m (AsyncWait b), a)]
later
[(String, a)]
following <- [(AsyncWait b, a)] -> [(m (AsyncWait b), a)] -> m [(String, a)]
recursive ([(AsyncWait b, a)]
running [(AsyncWait b, a)] -> [(AsyncWait b, a)] -> [(AsyncWait b, a)]
forall a. [a] -> [a] -> [a]
++ [(AsyncWait b, a)]
new) (Int -> [(m (AsyncWait b), a)] -> [(m (AsyncWait b), a)]
forall a. Int -> [a] -> [a]
drop Int
k [(m (AsyncWait b), a)]
later)
[(String, a)] -> m [(String, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, a)] -> m [(String, a)])
-> [(String, a)] -> m [(String, a)]
forall a b. (a -> b) -> a -> b
$ [(String, a)]
done [(String, a)] -> [(String, a)] -> [(String, a)]
forall a. [a] -> [a] -> [a]
++ [(String, a)]
following