diff --git a/effectful-cli.cabal b/effectful-cli.cabal --- a/effectful-cli.cabal +++ b/effectful-cli.cabal @@ -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 diff --git a/src/Data/CLI/Args.hs b/src/Data/CLI/Args.hs --- a/src/Data/CLI/Args.hs +++ b/src/Data/CLI/Args.hs @@ -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 diff --git a/src/Data/CLI/Impl.hs b/src/Data/CLI/Impl.hs --- a/src/Data/CLI/Impl.hs +++ b/src/Data/CLI/Impl.hs @@ -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 diff --git a/src/Data/Error/CLI.hs b/src/Data/Error/CLI.hs --- a/src/Data/Error/CLI.hs +++ b/src/Data/Error/CLI.hs @@ -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 diff --git a/src/Effectful/CLI/Conc.hs b/src/Effectful/CLI/Conc.hs --- a/src/Effectful/CLI/Conc.hs +++ b/src/Effectful/CLI/Conc.hs @@ -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 ..] diff --git a/src/Effectful/CLI/IO.hs b/src/Effectful/CLI/IO.hs --- a/src/Effectful/CLI/IO.hs +++ b/src/Effectful/CLI/IO.hs @@ -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 diff --git a/src/Effectful/CLI/Sleep.hs b/src/Effectful/CLI/Sleep.hs --- a/src/Effectful/CLI/Sleep.hs +++ b/src/Effectful/CLI/Sleep.hs @@ -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)) diff --git a/src/Effectful/CLI/Time.hs b/src/Effectful/CLI/Time.hs --- a/src/Effectful/CLI/Time.hs +++ b/src/Effectful/CLI/Time.hs @@ -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 diff --git a/src/Effectful/Logger.hs b/src/Effectful/Logger.hs --- a/src/Effectful/Logger.hs +++ b/src/Effectful/Logger.hs @@ -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