packages feed

effectful-cli 0.1.0.0 → 0.1.0.1

raw patch · 9 files changed

+132/−45 lines, 9 files

Files

effectful-cli.cabal view
@@ -5,9 +5,9 @@ -- see: https://github.com/sol/hpack  name:           effectful-cli-version:        0.1.0.0+version:        0.1.0.1 synopsis:       CLI helpers for the effectful ecosystem-description:    Please see the README.+description:    Please see the README at https://github.com/haskell-github-trust/effectful-cli category:       CLI author:         drlkf maintainer:     drlkf <drlkf@drlkf.net>
src/Data/CLI/Args.hs view
@@ -25,19 +25,27 @@ logLevels =   [("debug", LevelDebug), ("info", LevelInfo), ("warn", LevelWarn), ("error", LevelError)] --- | @since 0.1.0.0+-- | Effective log level: @--log-level@ if given, else debug with @--debug@, else info.+--+-- @since 0.1.0.0 getLogLevel :: CLIArgs c -> LogLevel getLogLevel a = fromMaybe (if _debug a then LevelDebug else LevelInfo) (_logLevel a) --- | @since 0.1.0.0+-- | Print the version string to stdout.+--+-- @since 0.1.0.0 showVersion :: String -> IO () showVersion = putStrLn --- | @since 0.1.0.0+-- | Print the version if @--version@ was passed, otherwise run the parsed command.+--+-- @since 0.1.0.0 versionOrCommand :: String -> CLIArgs c -> (c -> IO ()) -> IO () versionOrCommand v a run = either (const (showVersion v)) run (_command a) --- | @since 0.1.0.0+-- | Parser for the common CLI options, wrapping the given command parser.+--+-- @since 0.1.0.0 argParser :: Parser c -> Parser (CLIArgs c) argParser cmdParser =   CLIArgs
src/Data/CLI/Impl.hs view
@@ -22,15 +22,21 @@ import Text.Megaparsec (Parsec, eof, errorBundlePretty, runParser) import Text.Printf (printf) --- | @since 0.1.0.0+-- | Error for 'succ' called on 'maxBound' of the named enum.+--+-- @since 0.1.0.0 unboundEnumError :: String -> a unboundEnumError name = error (printf "%s.Enum: succ invoked on maxBound" name) --- | @since 0.1.0.0+-- | Turn a megaparsec parser into a 'ReadM', requiring the whole input to be consumed.+--+-- @since 0.1.0.0 fromParsec :: String -> Parsec Void String a -> ReadM a fromParsec name p = eitherReader (first errorBundlePretty . runParser (p <* eof) name) --- | @since 0.1.0.0+-- | Accept a value either as a positional argument or as a @-c@/@--name@ option.+--+-- @since 0.1.0.0 argOrOpt   :: String   -> Char@@ -45,32 +51,46 @@   var = fmap toUpper name   r = either (fromParsec name) id p --- | @since 0.1.0.0+-- | Parser for a command that takes no arguments.+--+-- @since 0.1.0.0 noArgs :: a -> Parser a noArgs = pure --- | @since 0.1.0.0+-- | @-f@/@--force@ switch.+--+-- @since 0.1.0.0 forceSwitch :: Parser Bool forceSwitch = switch (short 'f' <> long "force" <> help "force unsafe behavior") --- | @since 0.1.0.0+-- | @-n@/@--noop@ switch for dry runs.+--+-- @since 0.1.0.0 noopSwitch :: Parser Bool noopSwitch = switch (short 'n' <> long "noop" <> help "do not perform any real action") --- | @since 0.1.0.0+-- | UUID given as a positional argument or @-u@/@--uuid@.+--+-- @since 0.1.0.0 uuidArg :: Parser UUID uuidArg = argOrOpt "uuid" 'u' "target uuid" (Right (maybeReader UUID.fromString)) [] --- | @since 0.1.0.0+-- | Build a subcommand from a 'Command' instance.+--+-- @since 0.1.0.0 mkCommand :: Command c e a => a -> Mod CommandFields a mkCommand a = command (cmdname a) (info (parser a) (progDesc (doc a))) --- | @since 0.1.0.0+-- | Build subcommands for every value of an enum, sorted by name and wrapped with the given constructor.+--+-- @since 0.1.0.0 mkCommands   :: Bounded a => Command c e a => Command c e b => Enum a => (a -> b) -> Mod CommandFields b mkCommands f = foldMap (mkCommand . f) (sortOn cmdname [minBound ..]) --- | @since 0.1.0.0+-- | Top-level 'ParserInfo' with @--help@ and a header showing name, description and version.+--+-- @since 0.1.0.0 usage :: String -> String -> String -> Parser a -> ParserInfo a usage name version hdr p =   info
src/Data/Error/CLI.hs view
@@ -11,7 +11,9 @@   | UserCanceled (Maybe String)   deriving (Eq, Show) --- | @since 0.1.0.0+-- | Render a 'CLIError' as a human-readable message.+--+-- @since 0.1.0.0 displayCLIError :: CLIError -> String displayCLIError (InputError s) = "input error: " <> s displayCLIError (NotFoundError s) = "not found: " <> s
src/Effectful/CLI/Conc.hs view
@@ -26,28 +26,40 @@   pooledMapConcurrentlyN_,  ) --- | @since 0.1.0.0+-- | Run all actions concurrently and collect their results.+--+-- @since 0.1.0.0 runConcurrently :: Concurrent :> es => Traversable t => t (Eff es a) -> Eff es (t a) runConcurrently = mapConcurrently id --- | @since 0.1.0.0+-- | Run all actions concurrently, discarding results.+--+-- @since 0.1.0.0 runConcurrently_ :: Concurrent :> es => Foldable t => t (Eff es a) -> Eff es () runConcurrently_ = mapConcurrently_ id --- | @since 0.1.0.0+-- | Map over a list with at most @n@ concurrent actions.+--+-- @since 0.1.0.0 batchConcurrently :: Concurrent :> es => Int -> (a -> Eff es b) -> [a] -> Eff es [b] batchConcurrently = pooledMapConcurrentlyN --- | @since 0.1.0.0+-- | Like 'batchConcurrently', discarding results.+--+-- @since 0.1.0.0 batchConcurrently_ :: Concurrent :> es => Int -> (a -> Eff es b) -> [a] -> Eff es () batchConcurrently_ = pooledMapConcurrentlyN_ --- | @since 0.1.0.0+-- | Like 'batchConcurrently', also passing each element's 1-based index.+--+-- @since 0.1.0.0 batchConcurrentlyWithIndex   :: Concurrent :> es => Int -> (Int -> a -> Eff es b) -> [a] -> Eff es [b] batchConcurrentlyWithIndex n f = batchConcurrently n (uncurry f) . zip [1 ..] --- | @since 0.1.0.0+-- | Like 'batchConcurrentlyWithIndex', discarding results.+--+-- @since 0.1.0.0 batchConcurrentlyWithIndex_   :: Concurrent :> es => Int -> (Int -> a -> Eff es b) -> [a] -> Eff es () batchConcurrentlyWithIndex_ n f = batchConcurrently_ n (uncurry f) . zip [1 ..]
src/Effectful/CLI/IO.hs view
@@ -31,45 +31,62 @@ import Text.Megaparsec.Char.Lexer (decimal, signed) import Text.Printf (printf) --- | @since 0.1.0.0+-- | Print to stdout without a trailing newline.+--+-- @since 0.1.0.0 printOutput :: IOE :> es => String -> Eff es () printOutput = liftIO . putStr --- | @since 0.1.0.0+-- | Print to stdout with a trailing newline.+--+-- @since 0.1.0.0 printOutputLn :: IOE :> es => String -> Eff es () printOutputLn = liftIO . putStrLn --- | @since 0.1.0.0+-- | Print to stderr without a trailing newline.+--+-- @since 0.1.0.0 printError :: IOE :> es => String -> Eff es () printError = liftIO . hPutStr stderr --- | @since 0.1.0.0+-- | Print lines to stdout, each followed by a newline.+--+-- @since 0.1.0.0 printLines :: IOE :> es => [String] -> Eff es () printLines = printOutput . unlines --- | @since 0.1.0.0+-- | Read a line from stdin after printing an optional prompt to stderr.+--+-- @since 0.1.0.0 prompt :: IOE :> es => Maybe String -> Eff es String prompt p = liftIO $ do   hPutStr stderr (fromMaybe "" p <> "> ")   hFlush stderr   getLine --- | @since 0.1.0.0+-- | Prompt and parse the answer, throwing 'InputError' on parse failure.+--+-- @since 0.1.0.0 prompt'   :: Error CLIError :> es => IOE :> es => Maybe String -> Parsec Void String a -> Eff es a prompt' p parser =   prompt p     >>= either (throwError . InputError . errorBundlePretty) pure . runParser parser "prompt" --- | @since 0.1.0.0+-- | Ask for confirmation; @y@, @yes@ or an empty answer mean yes.+--+-- @since 0.1.0.0 askForConfirm :: Error CLIError :> es => IOE :> es => Eff es Bool askForConfirm = prompt' (Just "proceed ?") yesOrNo  where   yes = void (string' "y" <|> string' "yes") <|> eof   yesOrNo = (yes $> True) <|> pure False --- | Ambiguous in @c@: call as @withConfirm @MyConfig@.+-- | Run the action after user confirmation, honoring the config's auto-accept and+-- auto-decline flags; throws 'UserCanceled' when declined. --+-- Ambiguous in @c@: call as @withConfirm @MyConfig@.+-- -- @since 0.1.0.0 withConfirm   :: forall c es a@@ -82,11 +99,15 @@     unless ok $ throwError (UserCanceled Nothing)   action --- | @since 0.1.0.0+-- | Open a file or URL with @xdg-open@.+--+-- @since 0.1.0.0 autoOpen :: Process :> es => String -> Eff es () autoOpen arg = callProcess "xdg-open" [arg] --- | @since 0.1.0.0+-- | Let the user pick one item from a table; a single item is returned without prompting, none throws 'NotFoundError'.+--+-- @since 0.1.0.0 chooseItem   :: Error CLIError :> es   => IOE :> es
src/Effectful/CLI/Sleep.hs view
@@ -19,19 +19,25 @@ import Effectful.Logger (Logger) import Text.Printf (printf) --- | @since 0.1.0.0+-- | Sleep for the given number of milliseconds.+--+-- @since 0.1.0.0 msleep :: IOE :> es => Logger :> es => Int -> Eff es () msleep n = do   logDebugN (T.pack (printf "sleeping for %dms" n))   liftIO (threadDelay (n * 1000)) --- | @since 0.1.0.0+-- | Sleep for the given number of seconds.+--+-- @since 0.1.0.0 sleep :: IOE :> es => Logger :> es => Int -> Eff es () sleep n = do   logDebugN (T.pack (printf "sleeping for %ds" n))   liftIO (threadDelay (n * 1000000)) --- | @since 0.1.0.0+-- | Sleep until the given local time.+--+-- @since 0.1.0.0 sleepUntil :: IOE :> es => Logger :> es => LocalTime -> Eff es () sleepUntil t = do   logInfoN (T.pack ("sleeping until " <> formatTime defaultTimeLocale "%R" t))
src/Effectful/CLI/Time.hs view
@@ -10,26 +10,38 @@ import Data.Time import Effectful (Eff, IOE, liftIO, (:>)) --- | @since 0.1.0.0+-- | Current time in the local time zone.+--+-- @since 0.1.0.0 getLocalTimeIO :: IO LocalTime getLocalTimeIO = utcToLocalTime <$> getCurrentTimeZone <*> getCurrentTime --- | @since 0.1.0.0+-- | Midnight UTC of the current day.+--+-- @since 0.1.0.0 getBeginningOfDayIO :: IO UTCTime getBeginningOfDayIO = (\now -> now{utctDayTime = 0}) <$> getCurrentTime --- | @since 0.1.0.0+-- | Midnight UTC of the Monday of the current week.+--+-- @since 0.1.0.0 getBeginningOfWeekIO :: IO UTCTime getBeginningOfWeekIO = (\now -> UTCTime (weekFirstDay Monday (utctDay now)) 0) <$> getCurrentTime --- | @since 0.1.0.0+-- | Current time in the local time zone.+--+-- @since 0.1.0.0 getLocalTime :: IOE :> es => Eff es LocalTime getLocalTime = liftIO getLocalTimeIO --- | @since 0.1.0.0+-- | Midnight UTC of the current day.+--+-- @since 0.1.0.0 getBeginningOfDay :: IOE :> es => Eff es UTCTime getBeginningOfDay = liftIO getBeginningOfDayIO --- | @since 0.1.0.0+-- | Midnight UTC of the Monday of the current week.+--+-- @since 0.1.0.0 getBeginningOfWeek :: IOE :> es => Eff es UTCTime getBeginningOfWeek = liftIO getBeginningOfWeekIO
src/Effectful/Logger.hs view
@@ -44,15 +44,21 @@  newtype instance StaticRep Logger = Logger LogFunc --- | @since 0.1.0.0+-- | Run the 'Logger' effect with the given log callback.+--+-- @since 0.1.0.0 runLogger :: IOE :> es => LogFunc -> Eff (Logger : es) a -> Eff es a runLogger = evalStaticRep . Logger --- | @since 0.1.0.0+-- | Run the 'Logger' effect, writing to stderr.+--+-- @since 0.1.0.0 runStderrLogger :: IOE :> es => Eff (Logger : es) a -> Eff es a runStderrLogger = runLogger (defaultOutput stderr) --- | @since 0.1.0.0+-- | Run the 'Logger' effect, emitting OpenTelemetry log records.+--+-- @since 0.1.0.0 runOTelLogger :: IOE :> es => OTel.Logger -> Eff (Logger : es) a -> Eff es a runOTelLogger = runLogger . OTel.makeOTelLogCallback