Commit 2a4f8320 authored by Valentin Reis's avatar Valentin Reis

refactoring to protolude.

parent 73c9d00c
Pipeline #6105 failed with stages
in 1 minute and 34 seconds
......@@ -18,7 +18,10 @@ executable argotk
-- other-extensions:
build-depends:
base,
protolude,
shake,
directory,
typed-process,
turtle,
data-default,
async,
......
......@@ -15,7 +15,7 @@
"name": "argo/container",
"value": {
"cpus": "48",
"mems": "1"
"mems": "2"
}
},
{
......
This diff is collapsed.
{-# language GeneralizedNewtypeDeriving #-}
{-# language OverloadedStrings #-}
{-# language NoImplicitPrelude #-}
{-|
Module : Argo.Types
......@@ -36,8 +37,7 @@ where
import Data.Default
import Data.Text as T
hiding ( empty )
import Turtle hiding ( option )
import Prelude hiding ( FilePath )
import Protolude
data StackArgs = StackArgs
{ verbosity :: Verbosity
......@@ -59,16 +59,16 @@ data StackArgs = StackArgs
, powercap :: PowerCap
} deriving (Show)
{-data OutputFiles = OutputFiles FilePath FilePath-}
{-data OutputFiles = OutputFiles Text Text-}
data Verbosity = Normal | Verbose deriving (Show, Read, Eq)
newtype EnvVar = EnvVar Text deriving (Show, Read)
newtype HwThreadCount = HwThreadCount Int deriving (Show, Read, Eq)
newtype AppArg = AppArg Text deriving (IsString, Show, Read)
newtype WorkingDirectory = WorkingDirectory FilePath deriving (IsString, Show)
newtype WorkingDirectory = WorkingDirectory Text deriving (IsString, Show)
newtype AppName = AppName Text deriving (IsString, Show, Read)
newtype ContainerName = ContainerName Text deriving (IsString, Show, Read)
newtype ShareDir = ShareDir FilePath deriving (IsString, Show)
newtype ManifestName = ManifestName FilePath deriving (IsString, Show)
newtype ShareDir = ShareDir Text deriving (IsString, Show)
newtype ManifestName = ManifestName Text deriving (IsString, Show)
newtype PreludeCommand = PreludeCommand Text deriving (IsString, Show, Read)
data ProcessBehavior =
Test TestText StdOutLog StdErrLog
......@@ -85,7 +85,7 @@ data TextBehavior =
data PowerCap = Fixed Int | Adaptive | None deriving (Show, Read, Eq)
class ToDaemonOption a where
toOption :: a -> [String]
toOption :: a -> [Text]
instance ToDaemonOption Verbosity where
toOption Verbose = ["--verbose"]
......
This diff is collapsed.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Main
( main
......@@ -13,14 +14,15 @@ License : MIT
Maintainer : fre@freux.fr
-}
import Protolude
import Data.Coerce ( coerce )
import Data.Foldable ( for_ )
import Argo.Stack
import Argo.Utils
import Argo.Types
import Argo.Args
import Turtle
import Prelude hiding ( FilePath )
import Turtle hiding (repr)
import Prelude hiding ( FilePath, show)
import Data.Default
import System.Environment
import Options.Applicative hiding ( action )
......@@ -213,7 +215,7 @@ configureTest RunOpenMC = mkRun updater "run OpenMC in the Argo stack."
{ preludeCommand = PreludeCommand "cp -r $OPENMC_PWD/* ."
, app = AppName "mpiexec"
, args = let tc = coerce (hwThreadCount sa) :: Int
in fmap AppArg ["-n", repr tc, "openmc"]
in fmap AppArg ["-n", show tc, "openmc"]
}
configureTest RunQMCPack = mkRun updater "run QMCPack in the Argo stack."
......@@ -223,7 +225,7 @@ configureTest RunQMCPack = mkRun updater "run QMCPack in the Argo stack."
, args = let tc = coerce (hwThreadCount sa) :: Int
(ShareDir dirn) = shareDir sa
Right inpath = toText (dirn </> "simple-H2O.xml")
in fmap AppArg ["-n", repr tc, "qmcpack", inpath]
in fmap AppArg ["-n", show tc, "qmcpack", inpath]
}
configureTest RunAMG = mkRun updater "run AMG in the Argo stack."
......@@ -235,7 +237,7 @@ configureTest RunAMG = mkRun updater "run AMG in the Argo stack."
in fmap
AppArg
[ "-n"
, repr tc
, show tc
, "amg"
, "-problem"
, "2"
......@@ -245,31 +247,31 @@ configureTest RunAMG = mkRun updater "run AMG in the Argo stack."
, "90"
, "-P"
, "2"
, repr $ quot tc 2
, show $ quot tc 2
, "1"
]
}
configureTest RunSTREAM = mkRun updater "run STREAM in the Argo stack."
where updater sa = sa { app = AppName "stream_c" }
where
updater sa = sa
{ app = AppName "stream_c"
, vars = vars sa
++ [ (EnvVar "OMP_NUM_THREADS", "24")
, (EnvVar "OMP_PLACES" , "cores")
]
}
configureTest RunLAMMPS = mkRun updater "run LAMMPS in the argo stack."
where
updater sa = sa
{ app = AppName "mpirun"
, args = let (ShareDir dirn) = shareDir sa
Right inpath = toText (dirn </> "modified.lj")
in fmap
AppArg
[ "-n"
, repr (coerce (hwThreadCount sa) :: Int)
, "lmp_mpi"
, "-i"
, inpath
]
, args =
let (ShareDir dirn) = shareDir sa
Right inpath = toText (dirn </> "modified.lj")
in fmap AppArg ["-n", "24", "-bind-to", "core", "lmp_mpi", "-i", inpath]
}
-- converting a run to a test.
--------------------------------------------------------------------------------
......@@ -303,15 +305,17 @@ testProgressFromRun = testFromRun updater
-- parsing and building the shell monad
--------------------------------------------------------------------------------
opts :: StackArgs -> Parser (Shell ())
opts :: StackArgs -> Parser (IO ())
opts sa = hsubparser
( command "clean"
(info (pure $ clean sa) (progDesc "Clean sockets, logfiles."))
<> mconcat (fmap commandTest [(minBound :: TestName) ..])
<> commandTests [TestQMCPack, TestLAMMPS, TestOpenMC, TestAMG, TestSTREAM]
<> mconcat (fmap (commandTest sa) [(minBound :: TestName) ..])
<> commandTests sa
[TestQMCPack, TestLAMMPS, TestOpenMC, TestAMG, TestSTREAM]
"testApplications"
"Run application CI tests"
<> commandTests [TestHello, TestListen]
<> commandTests sa
[TestHello, TestListen]
"tests"
"Run hardware-independent CI tests"
<> help
......@@ -320,69 +324,77 @@ opts sa = hsubparser
<> "values are printed when you call --help on these actions."
)
)
where
action ttype = doOverridenTest ttype
<$> parseExtendStackArgs ((stackArgsUpdate $ configureTest ttype) sa)
descTest ttype = description (configureTest ttype)
commandTest ttype = command (show ttype)
$ info (action ttype) (progDesc $ T.unpack $ descTest ttype)
commandTests ttypes cmdStr descStr = command cmdStr
$ info (pure $ for_ ttypes (doTest sa)) (progDesc $ T.unpack descStr)
doTest :: StackArgs -> TestName -> Shell ()
doTest stackArgs ttype = doSpec spec
$ (stackArgsUpdate $ configureTest ttype) stackArgs
where spec = configureTest ttype
doOverridenTest :: TestName -> StackArgs -> Shell ()
doOverridenTest ttype = doSpec spec where spec = configureTest ttype
doSpec :: TestSpec -> StackArgs -> Shell ()
doSpec spec stackArgs = do
printTest $ description spec
fullStack (isTest spec) stackArgs
printSuccess "Test Successful.\n"
action :: StackArgs -> TestName -> Parser (IO ())
action sa testName = doOverridenTest testName
<$> parseExtendStackArgs ((stackArgsUpdate $ configureTest testName) sa)
commandTests
:: StackArgs -> [TestName] -> String -> Text -> Mod CommandFields (IO ())
commandTests sa testNames cmdStr descStr = command cmdStr
$ info (pure $ for_ testNames (doTest sa)) (progDesc $ T.unpack descStr)
commandTest :: StackArgs -> TestName -> Mod CommandFields (IO ())
commandTest sa testName = command (show testName)
$ info (action sa testName) (progDesc $ T.unpack $ descTest testName)
descTest :: TestName -> Text
descTest testName = description (configureTest testName)
doTest :: StackArgs -> TestName -> IO ()
doTest stackArgs testName = doSpec spec
$ (stackArgsUpdate $ configureTest testName) stackArgs
where spec = configureTest testName
doOverridenTest :: TestName -> StackArgs -> IO ()
doOverridenTest testName = doSpec spec where spec = configureTest testName
doSpec :: TestSpec -> StackArgs -> IO ()
doSpec spec stackArgs = do
putText $ description spec
fullStack (isTest spec) stackArgs
putText "Test Successful.\n"
-- executors
--------------------------------------------------------------------------------
fullStack :: IsTest -> StackArgs -> Shell ()
fullStack :: IsTest -> StackArgs -> IO ()
fullStack isTest a@StackArgs {..} = do
stackOutput <- runStack a
case stackOutput of
FoundMessage msg -> printSuccess $ "Found string in message:" <> repr msg
FoundMessage msg -> putText $ "Found string in message:" <> toS msg
FoundTracebacks tsl -> do
for_ tsl $ \(stacki, fout, ferr) ->
printError
putText
$ "Found Python Traceback when executing "
<> repr stacki
<> show stacki
<> ". Files for this command: "
<> repr fout
<> toS fout
<> " "
<> repr ferr
<> toS ferr
exit (ExitFailure 1)
Died stacki errorcode _ _ tsl -> case isTest of
IsTest -> do
printError
( repr stacki
putText
( show stacki
<> " died before a message could be found with error code "
<> repr errorcode
<> show errorcode
)
for_
tsl
(\(stacki', fout, ferr) ->
printError
putText
$ "Found Python Traceback when executing "
<> repr stacki'
<> show stacki'
<> ". Files for this command: "
<> repr fout
<> toS fout
<> " "
<> repr ferr
<> toS ferr
)
exit (ExitFailure 1)
NotTest -> exit ExitSuccess
clean :: StackArgs -> Shell ()
clean :: StackArgs -> IO ()
clean StackArgs {..} = cleanLeftovers workingDirectory
-- the entry point with dirty setup IO and env. var fuckery, and finally
......@@ -399,5 +411,5 @@ main = do
, vars = vars
, hwThreadCount = HwThreadCount (read $ unpack $ lineToText hwlocTC)
}
turtle <- execParser (info (opts a <**> helper) idm)
sh turtle
parsed <- execParser (info (opts a <**> helper) idm)
parsed
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment