Commit 6ee0a893 authored by Valentin Reis's avatar Valentin Reis
Browse files

Refactor with haskell-tools-cli

parent 1b92fba4
.PHONY: ghcid-tests ghcid-lib .PHONY: ghcid-tests ghcid-lib
.PHONY: ht-refact-core
.PHONY: brittany-core
.PHONY: codequality
ghcid-lib: codequality : ht-refact brittany
sh -c "while true; do \
nix-shell \ ht-refact:
--run 'ghcid \ nix-shell \
--command \"cabal repl --ghc-options=-fno-code --ghc-options=-fno-break-on-exception --ghc-options=-fno-break-on-error --ghc-options=-v1 --ghc-options=-ferror-spans --ghc-options=-j\" \ --run 'ht-refact \
--restart=argotk.cabal \ -w `which hfswatch` \
--restart=default.nix\ --project-type cabal \
--restart=shell.nix'\ . \
; done" -e \
"OrganizeExtensions Argo.Stack\
OrganizeExtensions Argo.Args ;\
OrganizeExtensions Argo.Utils ;\
OrganizeExtensions Argo.Types ;\
OrganizeImports Argo.Stack ;\
OrganizeImports Argo.Args ;\
OrganizeImports Argo.Utils ;\
OrganizeImports Argo.Types ;\
GenerateExports Argo.Stack ;\
GenerateExports Argo.Args ;\
GenerateExports Argo.Utils ;\
GenerateExports Argo.Types\
"' || true
brittany:
nix-shell \
--run 'brittany --write-mode inplace src/*.hs src/Argo/*hs'
...@@ -60,16 +60,15 @@ argotk TestHello --help ...@@ -60,16 +60,15 @@ argotk TestHello --help
Output: Output:
``` {.txt} ``` {.txt}
Usage: argotk TestHello [-v|--verbose] [--app APP] Usage: argotk TestHello [-v|--verbose] [--app APP] [ENVvar] [ARGS]
[--container_name ARGO_CONTAINER_UUID] [--container_name ARGO_CONTAINER_UUID]
[--output_dir DIR] [--manifest_directory DIR] [--output_dir DIR] [--manifest_directory DIR]
[--manifest_name FILENAME] [--prelude_command COMMAND] [--manifest_name FILENAME] [--prelude_command COMMAND]
[--daemon BEHAVIOR] [--cmd_run BEHAVIOR] [--daemon BEHAVIOR] [--cmd_run BEHAVIOR]
[--cmd_listen BEHAVIOR] [--cmd_listen BEHAVIOR] [--cmd_listen_progress BEHAVIOR]
[--cmd_listen_performance BEHAVIOR] [--cmd_listen_performance BEHAVIOR]
[--cmd_listen_progress BEHAVIOR]
[--cmd_listen_power BEHAVIOR] [--threadCount THREADS] [--cmd_listen_power BEHAVIOR] [--threadCount THREADS]
[--powercap POWERCAP] [ARGS] [--powercap POWERCAP]
Setup stack and check that a hello world app sendsmessage back to cmd's Setup stack and check that a hello world app sendsmessage back to cmd's
stdout. stdout.
...@@ -77,13 +76,15 @@ Available options: ...@@ -77,13 +76,15 @@ Available options:
-v,--verbose Enable verbose mode -v,--verbose Enable verbose mode
--app APP Target application executable name. PATH is --app APP Target application executable name. PATH is
inherited. (default: AppName "echo") inherited. (default: AppName "echo")
ENVvar Env.Vars. for running app.
ARGS Application arguments.
--container_name ARGO_CONTAINER_UUID --container_name ARGO_CONTAINER_UUID
Container Container
name (default: ContainerName "testContainer") name (default: ContainerName "testContainer")
--output_dir DIR Working --output_dir DIR Working
directory. (default: WorkingDirectory (FilePath "_output")) directory. (default: WorkingDirectory (FilePath "_output"))
--manifest_directory DIR Manifest lookup --manifest_directory DIR Manifest lookup
directory (default: ShareDir (FilePath "/nix/store/mdfc7ipmx44j1ydq3c3gv0h03lmgk9jc-argotk-0.1.0.0/share")) directory (default: ShareDir (FilePath "/nix/store/w0cji2rimg3g48gfjncmysdbms7mg8ql-argotk-0.1.0.0/share"))
--manifest_name FILENAME Manifest file basename (relative to --manifest_name FILENAME Manifest file basename (relative to
--manifest_directory) (default: ManifestName (FilePath "basic.json")) --manifest_directory) (default: ManifestName (FilePath "basic.json"))
--prelude_command COMMAND --prelude_command COMMAND
...@@ -94,12 +95,12 @@ Available options: ...@@ -94,12 +95,12 @@ Available options:
--cmd_run BEHAVIOR `cmd run` --cmd_run BEHAVIOR `cmd run`
behavior (default: Test (TestText (TextBehaviorStdout (WaitFor "someComplexTextMessage12349")) (TextBehaviorStderr ExpectClean)) (StdOutLog "monitored-cmdrun-out.log") (StdErrLog "monitored-cmdrun-err.log")) behavior (default: Test (TestText (TextBehaviorStdout (WaitFor "someComplexTextMessage12349")) (TextBehaviorStderr ExpectClean)) (StdOutLog "monitored-cmdrun-out.log") (StdErrLog "monitored-cmdrun-err.log"))
--cmd_listen BEHAVIOR `cmd listen` behavior (default: DontRun) --cmd_listen BEHAVIOR `cmd listen` behavior (default: DontRun)
--cmd_listen_performance BEHAVIOR
`cmd listen --filter performance`
behavior (default: DontRun)
--cmd_listen_progress BEHAVIOR --cmd_listen_progress BEHAVIOR
`cmd listen --filter progress` `cmd listen --filter progress`
behavior (default: DontRun) behavior (default: DontRun)
--cmd_listen_performance BEHAVIOR
`cmd listen --filter performance`
behavior (default: DontRun)
--cmd_listen_power BEHAVIOR --cmd_listen_power BEHAVIOR
`cmd listen --filter power` `cmd listen --filter power`
behavior (default: DontRun) behavior (default: DontRun)
...@@ -107,7 +108,6 @@ Available options: ...@@ -107,7 +108,6 @@ Available options:
stack. (default: HwThreadCount 8) stack. (default: HwThreadCount 8)
--powercap POWERCAP Powercap strategy: Fixed x | None | --powercap POWERCAP Powercap strategy: Fixed x | None |
Adaptive (default: None) Adaptive (default: None)
ARGS Application arguments.
-h,--help Show this help text -h,--help Show this help text
``` ```
......
...@@ -4,16 +4,8 @@ ...@@ -4,16 +4,8 @@
rec { rec {
argotk = pkgs.argotk; argotk = pkgs.argotk;
hack = pkgs.argolib.getHackEnv pkgs pkgs.haskellPackages argotk; hack = pkgs.argolib.getHackEnv pkgs pkgs.haskellPackages argotk;
shakeEnv = pkgs.stdenv.mkDerivation { post = (pkgs.argolib.getPostEnv pkgs pkgs.haskellPackages argotk).overrideAttrs
name = "shake"; (old: {
ARGOTK_SHARE = "${argotk}/share"; ARGOTK_SHARE="${argotk}/share";
buildInputs = [ });
(pkgs.haskellPackages.ghcWithPackages (p: with p; [
argotk
pkgs.hwloc
shake
panpipe
]))
];
};
} }
#! /usr/bin/env nix-shell
#! nix-shell default.nix -i runhaskell -A shakeEnv
{-| {-|
Module : shake.hs Module : shake.hs
Description : dev tasks. Description : dev tasks.
Copyright : (c) Valentin Reis, 2018 Copyright : (c) Valentin Reis, 2018
License : MIT License : MIT
Maintainer : fre@freux.fr -} Maintainer : fre@freux.fr
-}
import Development.Shake import Development.Shake
import Protolude
import Development.Shake.FilePath import Development.Shake.FilePath
import Control.Monad import Control.Monad
refactCommands =
[ "OrganizeExtensions Argo.Args"
, "OrganizeExtensions Argo.Utils"
, "OrganizeExtensions Argo.Types"
, "OrganizeImports Argo.Stack"
, "OrganizeImports Argo.Args"
, "OrganizeImports Argo.Utils"
, "OrganizeImports Argo.Types"
, "GenerateExports Argo.Stack"
, "GenerateExports Argo.Args"
, "GenerateExports Argo.Utils"
, "GenerateExports Argo.Types"
]
main = shakeArgs shakeOptions $ do main = shakeArgs shakeOptions $ do
phony "clean" $ do phony "clean" $ removeFilesAfter "." ["README.md"]
removeFilesAfter "." ["README.md"]
phony "ghcid"
$ cmd_ Shell
$ "while true; do "
<> "nix-shell "
<> "--run 'ghcid "
<> "--command \"cabal repl --ghc-options=-fno-code "
<> "--ghc-options=-fno-break-on-exception "
<> "--ghc-options=-fno-break-on-error "
<> "--ghc-options=-v1 --ghc-options=-ferror-spans "
<> "--ghc-options=-j\" "
<> "--restart=argotk.cabal "
<> "--restart=default.nix"
<> "--restart=shell.nix'"
<> "; done"
phony "ht-refact" htRefactAll
phony "brittany" brittany
phony "codequality" $ brittany >> htRefactAll
want ["README.md"] want ["README.md"]
"README.md" %> \out -> do "README.md" %> \out -> do
let template = ".README.md" let template = ".README.md"
need [template , "src/argotk.hs" , "src/Argo/Stack.hs"] need [template, "src/argotk.hs", "src/Argo/Stack.hs"]
(Stdout panpipe) <- cmd "which panpipe" (Stdout panpipe) <- cmd "which panpipe"
cmd_ "pandoc --filter" cmd_ "pandoc --filter"
[take (length panpipe - 1) panpipe, template, "-o", out] [take (length panpipe - 1) panpipe, template, "-o", out]
where
brittany =
cmd_ Shell $ "brittany --write-mode inplace" <> " src/*.hs src/Argo/*hs"
htRefactAll = for_ refactCommands htRefact
htRefact x =
cmd_ Shell
$ "ht-refact "
<> "-w `which hfswatch` "
<> "--project-type cabal "
<> ". "
<> "-e \""
<> x
<> "\" || true"
{-# language OverloadedStrings #-} {-# language OverloadedStrings #-}
{-# language ApplicativeDo #-} {-# language ApplicativeDo #-}
{-# language RecordWildCards #-}
module Argo.Args module Argo.Args
( parseExtendStackArgs ( parseExtendStackArgs
...@@ -27,96 +26,115 @@ behaviorOption :: Mod OptionFields ProcessBehavior -> Parser ProcessBehavior ...@@ -27,96 +26,115 @@ behaviorOption :: Mod OptionFields ProcessBehavior -> Parser ProcessBehavior
behaviorOption = option behavior behaviorOption = option behavior
parseExtendStackArgs :: StackArgs -> Parser StackArgs parseExtendStackArgs :: StackArgs -> Parser StackArgs
parseExtendStackArgs sa = do parseExtendStackArgs sa =
verbosity <- flag StackArgs <$>
pverbosity
<*> papp
<*> pvars
<*> pargs
<*> pcontainerName
<*> pworkingDirectory
<*> pshareDir
<*> pmanifestName
<*> ppreludeCommand
<*> pdaemon
<*> pcmdrun
<*> pcmdlisten
<*> pcmdlistenprogress
<*> pcmdlistenperformance
<*> pcmdlistenpower
<*> phwThreadCount
<*> ppowercap
where
pverbosity = flag
Normal Normal
Verbose Verbose
(long "verbose" <> short 'v' <> help "Enable verbose mode") (long "verbose" <> short 'v' <> help "Enable verbose mode")
app <- strOption papp = strOption
( long "app" ( long "app"
<> metavar "APP" <> metavar "APP"
<> help "Target application executable name. PATH is inherited." <> help "Target application executable name. PATH is inherited."
<> showDefault <> showDefault
<> value (app sa) <> value (app sa)
) )
containerName <- strOption pcontainerName = strOption
( long "container_name" ( long "container_name"
<> metavar "ARGO_CONTAINER_UUID" <> metavar "ARGO_CONTAINER_UUID"
<> help "Container name" <> help "Container name"
<> showDefault <> showDefault
<> value (containerName sa) <> value (containerName sa)
) )
workingDirectory <- strOption pworkingDirectory = strOption
( long "output_dir" ( long "output_dir"
<> metavar "DIR" <> metavar "DIR"
<> help "Working directory." <> help "Working directory."
<> showDefault <> showDefault
<> value (workingDirectory sa) <> value (workingDirectory sa)
) )
shareDir <- strOption pshareDir = strOption
( long "manifest_directory" ( long "manifest_directory"
<> metavar "DIR" <> metavar "DIR"
<> help "Manifest lookup directory" <> help "Manifest lookup directory"
<> showDefault <> showDefault
<> value (shareDir sa) <> value (shareDir sa)
) )
manifestName <- strOption pmanifestName = strOption
( long "manifest_name" ( long "manifest_name"
<> metavar "FILENAME" <> metavar "FILENAME"
<> help "Manifest file basename (relative to --manifest_directory)" <> help "Manifest file basename (relative to --manifest_directory)"
<> showDefault <> showDefault
<> value (manifestName sa) <> value (manifestName sa)
) )
preludeCommand <- strOption ppreludeCommand = strOption
( long "prelude_command" ( long "prelude_command"
<> metavar "COMMAND" <> metavar "COMMAND"
<> help "Command to run before executing the stack (after stack setup)" <> help "Command to run before executing the stack (after stack setup)"
<> showDefault <> showDefault
<> value (preludeCommand sa) <> value (preludeCommand sa)
) )
daemon <- behaviorOption pdaemon = behaviorOption
( long "daemon" ( long "daemon"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`daemon` behavior" <> help "`daemon` behavior"
<> showDefault <> showDefault
<> value (daemon sa) <> value (daemon sa)
) )
cmdrun <- behaviorOption pcmdrun = behaviorOption
( long "cmd_run" ( long "cmd_run"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`cmd run` behavior" <> help "`cmd run` behavior"
<> showDefault <> showDefault
<> value (cmdrun sa) <> value (cmdrun sa)
) )
cmdlisten <- behaviorOption pcmdlisten = behaviorOption
( long "cmd_listen" ( long "cmd_listen"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`cmd listen` behavior" <> help "`cmd listen` behavior"
<> showDefault <> showDefault
<> value (cmdlisten sa) <> value (cmdlisten sa)
) )
cmdlistenperformance <- behaviorOption pcmdlistenperformance = behaviorOption
( long "cmd_listen_performance" ( long "cmd_listen_performance"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`cmd listen --filter performance` behavior" <> help "`cmd listen --filter performance` behavior"
<> showDefault <> showDefault
<> value (cmdlistenperformance sa) <> value (cmdlistenperformance sa)
) )
cmdlistenprogress <- behaviorOption pcmdlistenprogress = behaviorOption
( long "cmd_listen_progress" ( long "cmd_listen_progress"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`cmd listen --filter progress` behavior" <> help "`cmd listen --filter progress` behavior"
<> showDefault <> showDefault
<> value (cmdlistenprogress sa) <> value (cmdlistenprogress sa)
) )
cmdlistenpower <- behaviorOption pcmdlistenpower = behaviorOption
( long "cmd_listen_power" ( long "cmd_listen_power"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`cmd listen --filter power` behavior" <> help "`cmd listen --filter power` behavior"
<> showDefault <> showDefault
<> value (cmdlistenpower sa) <> value (cmdlistenpower sa)
) )
hwThreadCount <- option phwThreadCount = option
auto auto
( long "threadCount" ( long "threadCount"
<> metavar "THREADS" <> metavar "THREADS"
...@@ -124,7 +142,7 @@ parseExtendStackArgs sa = do ...@@ -124,7 +142,7 @@ parseExtendStackArgs sa = do
<> showDefault <> showDefault
<> value (hwThreadCount sa) <> value (hwThreadCount sa)
) )
powercap <- option ppowercap = option
auto auto
( long "powercap" ( long "powercap"
<> metavar "POWERCAP" <> metavar "POWERCAP"
...@@ -132,8 +150,8 @@ parseExtendStackArgs sa = do ...@@ -132,8 +150,8 @@ parseExtendStackArgs sa = do
<> showDefault <> showDefault
<> value (powercap sa) <> value (powercap sa)
) )
args <- some (argument str (metavar "ARGS" <> help "Application arguments.")) pargs = some (argument str (metavar "ARGS" <> help "Application arguments."))
<|> pure (args sa) <|> pure (args sa)
vars <- some (argument auto (metavar "ENVvar" <> help "Env.Vars. for running app.")) pvars =
<|> pure (vars sa) some (argument auto (metavar "ENVvar" <> help "Env.Vars. for running app."))
pure StackArgs {..} <|> pure (vars sa)
...@@ -12,8 +12,18 @@ Maintainer : fre@freux.fr ...@@ -12,8 +12,18 @@ Maintainer : fre@freux.fr
-} -}
module Argo.Stack module Argo.Stack
( StackOutput(..) ( cleanLeftovers
, cleanLeftovers , prepareDaemon
, cmdRunI
, cmdListenI
, cmdListenProgressI
, cmdListenPerformanceI
, cmdListenPowerI
, StackOutput(..)
, Tracebacks
, TracebackScanOut(..)
, TracebackScanErr(..)
, StackI(..)
, runStack , runStack
) )
where where
...@@ -21,27 +31,27 @@ where ...@@ -21,27 +31,27 @@ where
import Argo.Types import Argo.Types
import Data.Coerce ( coerce ) import Data.Coerce ( coerce )
import Prelude hiding ( FilePath )
import Turtle import Turtle
import Turtle.Shell import Turtle.Shell
import Prelude hiding ( FilePath )
import Filesystem.Path ( (</>) ) import Filesystem.Path ( (</>) )
import Control.Concurrent.Async import Control.Concurrent.Async
import Data.Text as T
hiding ( empty )
import Argo.Utils import Argo.Utils
import System.Process as P import Control.Foldl as Fold
hiding ( shell ) ( length )
import Control.Monad ( mapM_ import Control.Monad ( mapM_
, filterM , filterM
) )
import Data.Foldable ( for_ ) import Data.Foldable ( for_ )
import Data.Traversable ( for )
import Data.Maybe import Data.Maybe
import Control.Foldl as Fold import Data.Text as T
( length ) hiding ( empty )
import Data.Traversable ( for )
import System.Process as P
hiding ( shell )
import Text.Show.Pretty import Text.Show.Pretty
cleanLeftovers :: WorkingDirectory -> Shell () --TODO cleanLeftovers :: WorkingDirectory -> Shell () --TODO
......
...@@ -116,4 +116,3 @@ instance Default StackArgs where ...@@ -116,4 +116,3 @@ instance Default StackArgs where
, hwThreadCount = HwThreadCount 1 , hwThreadCount = HwThreadCount 1
, powercap = None , powercap = None
} }
...@@ -32,28 +32,42 @@ module Argo.Utils ...@@ -32,28 +32,42 @@ module Argo.Utils
where where
import Argo.Types import Argo.Types
import Turtle import Data.ByteString as B
hiding ( empty )
import Data.Conduit
import Data.Conduit.Process hiding ( shell )
import Prelude hiding ( FilePath ) import Prelude hiding ( FilePath )
import System.Console.ANSI import System.Console.ANSI
import System.Console.ANSI.Types ( Color ) import System.Console.ANSI.Types ( Color )
import System.Posix.Signals import System.Posix.Signals ( installHandler
import System.Process hiding ( shell ) , keyboardSignal
import Data.Conduit , Handler(..)
import Data.Conduit.Process hiding ( shell ) )
import Data.ByteString as B import Turtle
hiding ( empty )
import System.IO ( BufferMode(NoBuffering) import Control.Exception.Base ( Exception
, hSetBuffering , try
, throw
) )
import Control.Monad.IO.Unlift ( MonadIO(..) import Control.Monad.IO.Unlift ( MonadIO(..)
, withRunInIO , withRunInIO
) )
import Data.Text.Encoding as TE
import Data.Conduit.Combinators as CC import Data.Conduit.Combinators as CC
import Control.Exception.Base ( sinkHandle
import Data.Typeable , withSinkFile
)
import Data.Text as T import Data.Text as T
( unpack
, Text
)
import Data.Text.Encoding as TE
( decodeUtf8
, encodeUtf8
)
import Data.Typeable ( Typeable )
import System.IO ( BufferMode(NoBuffering)
, hSetBuffering
)
import qualified System.IO as IO import qualified System.IO as IO
-- | Miscellaneous printing utilities -- | Miscellaneous printing utilities
......
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
<