core-program 0.6.3.0 → 0.6.5.0

raw patch · 4 files changed

+194/−65 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• core-program.cabal +1/−1
• lib/Core/Program/Arguments.hs +105/−46
• lib/Core/Program/Context.hs +6/−0
• lib/Core/Program/Execute.hs +82/−18

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           core-program-version:        0.6.3.0+version:        0.6.5.0 synopsis:       Opinionated Haskell Interoperability description:    A library to help build command-line programs, both tools and                 longer-running daemons.

@@ -25,7 +25,9 @@       Config     , blankConfig     , simpleConfig+    , simpleConfig'     , complexConfig+    , complexConfig'     , baselineOptions     , Parameters (..)     , ParameterValue (..)@@ -115,8 +117,8 @@ -} data Config     = Blank-    | Simple [Options]-    | Complex [Commands]+    | Simple Description [Options]+    | Complex Description [Commands]  -- -- Those constructors are not exposed [and functions wrapping them are] partly@@ -200,9 +202,29 @@ @since 0.2.9 -} simpleConfig :: [Options] -> Config-simpleConfig options = Simple (options ++ baselineOptions)+simpleConfig options = Simple emptyRope (options ++ baselineOptions)  {- |+Declare a simple configuration as with 'simpleConfig', along with a+descriptive precis that will be printed at the top of the @--help@ output.+++@+\$ __./snippet --help__+A small but very useful program.++Usage:++    snippet [OPTIONS] <filename>+...+@++@since 0.6.5+-}+simpleConfig' :: Description -> [Options] -> Config+simpleConfig' description options = Simple description (options ++ baselineOptions)++{- | Declare a complex configuration (implying a larger tool with various "[sub]commands" or "modes"} for a program. You can specify global options applicable to all commands, a list of commands, and environment variables@@ -286,9 +308,22 @@ @since 0.2.9 -} complexConfig :: [Commands] -> Config-complexConfig commands = Complex (commands ++ [Global baselineOptions])+complexConfig commands = Complex emptyRope (commands ++ [Global baselineOptions])  {- |+Declare a complex configuration as with 'complexConfig', along with a+descriptive precis that will be printed at the top of the @--help@ output when+requesting help for the program as a whole.++If help is requested for one of the sub commands, the description from the+'Command' constructor will be used at the top of the output.++@since 0.6.5+-}+complexConfig' :: Description -> [Commands] -> Config+complexConfig' precis commands = Complex precis (commands ++ [Global baselineOptions])++{- | Description of the command-line structure of a program which has \"commands\" (sometimes referred to as \"subcommands\") representing different modes of operation. This is familiar from tools like /git/@@ -332,7 +367,7 @@  @         [ ...-        , 'Remaining' "The files you wish to delete permanently."+        , 'Remaining' \"The files you wish to delete permanently.\"         , ...         ] @@@ -344,10 +379,20 @@  @         [ ...-        , 'Variable' \"CRAZY_MODE\" "Specify how many crazies to activate."+        , 'Variable' \"CRAZY_MODE\" \"Specify how many crazies to activate.\"         , ...         ] @++Finally, there is a 'Descriptive' constructor which allows you to put a piece+of header text as a descriptive summary in help output before it starts+enumerating the options and arguments.++@+        [ 'Descriptive' \"A program to evaluate just how crazy you are.\"+        , ...+        ]+@ -} data Options     = Option LongName (Maybe ShortName) ParameterValue Description@@ -360,8 +405,8 @@ appendOption option config =     case config of         Blank -> Blank-        Simple options -> Simple (options ++ [option])-        Complex commands -> Complex (commands ++ [Global [option]])+        Simple precis options -> Simple precis (options ++ [option])+        Complex precis commands -> Complex precis (commands ++ [Global [option]])  {- | Individual parameters read in off the command-line can either have a value@@ -550,11 +595,11 @@ parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters parseCommandLine config argv = case config of     Blank -> return (Parameters Nothing emptyMap [] emptyMap)-    Simple options -> do+    Simple _ options -> do         (params, remainder) <- extractor Nothing options argv         checkRemainder options remainder         return (Parameters Nothing params remainder emptyMap)-    Complex commands ->+    Complex _ commands ->         let globalOptions = extractGlobalOptions commands             modes = extractValidModes commands         in  do@@ -655,13 +700,13 @@                 Right (list, remainder) -> Right (((name, Value arg) : list), remainder)  parseIndicatedCommand-    :: Map LongName [Options]+    :: Map LongName (Description, [Options])     -> String     -> Either InvalidCommandLine (LongName, [Options]) parseIndicatedCommand modes first =     let candidate = LongName first     in  case lookupKeyValue candidate modes of-            Just options -> Right (candidate, options)+            Just (_, options) -> Right (candidate, options)             Nothing -> Left (UnknownCommand first)  --@@ -702,12 +747,12 @@     j (Global options) valids = options ++ valids     j _ valids = valids -extractValidModes :: [Commands] -> Map LongName [Options]+extractValidModes :: [Commands] -> Map LongName (Description, [Options]) extractValidModes commands =     List.foldl' k emptyMap commands   where-    k :: Map LongName [Options] -> Commands -> Map LongName [Options]-    k modes (Command longname _ options) = insertKeyValue longname options modes+    k :: Map LongName (Description, [Options]) -> Commands -> Map LongName (Description, [Options])+    k modes (Command longname description options) = insertKeyValue longname (description, options) modes     k modes _ = modes  {-@@ -740,8 +785,8 @@ extractValidEnvironments :: Maybe LongName -> Config -> Set LongName extractValidEnvironments mode config = case config of     Blank -> emptySet-    Simple options -> extractVariableNames options-    Complex commands ->+    Simple _ options -> extractVariableNames options+    Complex _ commands ->         let globals = extractGlobalOptions commands             variables1 = extractVariableNames globals @@ -775,9 +820,10 @@ buildUsage :: Config -> Maybe LongName -> Doc ann buildUsage config mode = case config of     Blank -> emptyDoc-    Simple options ->+    Simple precis options ->         let (o, a, v) = partitionParameters options-        in  "Usage:"+        in  formatPrecis precis+                <> "Usage:"                 <> hardline                 <> hardline                 <> indent@@ -799,36 +845,18 @@                 <> formatParameters a                 <> variablesHeading v                 <> formatParameters v-    Complex commands ->+    Complex precis commands ->         let globalOptions = extractGlobalOptions commands             modes = extractValidModes commands              (oG, _, vG) = partitionParameters globalOptions-        in  "Usage:" <> hardline <> hardline <> case mode of+        in  case mode of                 Nothing ->-                    indent-                        2-                        ( nest-                            4-                            ( fillCat-                                [ pretty programName-                                , globalSummary oG-                                , commandSummary modes-                                ]-                            )-                        )+                    formatPrecis precis+                        <> "Usage:"                         <> hardline-                        <> globalHeading oG-                        <> formatParameters oG-                        <> commandHeading modes-                        <> formatCommands commands-                        <> variablesHeading vG-                        <> formatParameters vG-                Just longname ->-                    let (oL, aL, vL) = case lookupKeyValue longname modes of-                            Just localOptions -> partitionParameters localOptions-                            Nothing -> error "Illegal State"-                    in  indent+                        <> hardline+                        <> indent                             2                             ( nest                                 4@@ -836,13 +864,39 @@                                     [ pretty programName                                     , globalSummary oG                                     , commandSummary modes-                                    , localSummary oL-                                    , argumentsSummary aL-                                    , remainingSummary aL                                     ]                                 )                             )+                        <> hardline+                        <> globalHeading oG+                        <> formatParameters oG+                        <> commandHeading modes+                        <> formatCommands commands+                        <> variablesHeading vG+                        <> formatParameters vG+                Just longname ->+                    let (dL, (oL, aL, vL)) = case lookupKeyValue longname modes of+                            Just (description, localOptions) -> (description, partitionParameters localOptions)+                            Nothing -> error "Illegal State"+                    in  formatPrecis dL+                            <> "Usage:"                             <> hardline+                            <> hardline+                            <> indent+                                2+                                ( nest+                                    4+                                    ( fillCat+                                        [ pretty programName+                                        , globalSummary oG+                                        , commandSummary modes+                                        , localSummary oL+                                        , argumentsSummary aL+                                        , remainingSummary aL+                                        ]+                                    )+                                )+                            <> hardline                             <> localHeading oL                             <> formatParameters oL                             <> argumentsHeading aL@@ -850,6 +904,11 @@                             <> variablesHeading vL                             <> formatParameters vL   where+    formatPrecis :: Description -> Doc ann+    formatPrecis precis = case widthRope precis of+        0 -> emptyDoc+        _ -> reflow (fromRope precis) <> hardline <> hardline+     partitionParameters :: [Options] -> ([Options], [Options], [Options])     partitionParameters options = List.foldl' f ([], [], []) options 

@@ -175,7 +175,9 @@     , exitSemaphoreFrom :: MVar ExitCode     , startTimeFrom :: MVar Time     , verbosityLevelFrom :: MVar Verbosity+    , outputSemaphoreFrom :: MVar ()     , outputChannelFrom :: TQueue (Maybe Rope) -- communication channels+    , telemetrySemaphoreFrom :: MVar ()     , telemetryChannelFrom :: TQueue (Maybe Datum) -- machinery for telemetry     , telemetryForwarderFrom :: Maybe Forwarder     , currentScopeFrom :: TVar (Set ThreadId)@@ -370,6 +372,8 @@     columns <- getConsoleWidth     coloured <- getConsoleColoured     level <- newEmptyMVar+    vo <- newEmptyMVar+    vl <- newEmptyMVar     out <- newTQueueIO     tel <- newTQueueIO @@ -389,7 +393,9 @@             , exitSemaphoreFrom = q             , startTimeFrom = i             , verbosityLevelFrom = level -- will be filled in handleVerbosityLevel+            , outputSemaphoreFrom = vo             , outputChannelFrom = out+            , telemetrySemaphoreFrom = vl             , telemetryChannelFrom = tel             , telemetryForwarderFrom = Nothing             , currentScopeFrom = scope

@@ -82,7 +82,6 @@       -- * Useful actions     , outputEntire     , inputEntire-    , execProcess     , sleepThread     , resetTimer     , trap_@@ -92,6 +91,10 @@     , throw     , try +      -- * Running processes+    , readProcess+    , execProcess_+       -- * Internals     , Context     , None (..)@@ -104,6 +107,7 @@     , lookupOptionValue     , lookupArgument     , lookupEnvironmentValue+    , execProcess     ) where @@ -117,7 +121,6 @@ import Control.Concurrent.MVar     ( MVar     , modifyMVar_-    , newEmptyMVar     , newMVar     , putMVar     , readMVar@@ -176,8 +179,8 @@     ) import System.Exit (ExitCode (..)) import System.Posix.Internals (hostIsThreaded)-import System.Posix.Process qualified as Posix (exitImmediately)-import System.Process.Typed (nullStream, proc, readProcess, setStdin)+import System.Posix.Process qualified as Posix (executeFile, exitImmediately)+import System.Process.Typed qualified as Typed (nullStream, proc, readProcess, setStdin) import Prelude hiding (log)  {- |@@ -253,23 +256,23 @@     level <- handleVerbosityLevel context      let quit = exitSemaphoreFrom context-        out = outputChannelFrom context-        tel = telemetryChannelFrom context-        forwarder = telemetryForwarderFrom context+    let vo = outputSemaphoreFrom context+    let out = outputChannelFrom context+    let vl = telemetrySemaphoreFrom context+    let tel = telemetryChannelFrom context+    let forwarder = telemetryForwarderFrom context      -- set up signal handlers     _ <- forkIO $ do         setupSignalHandlers quit level      -- set up standard output-    vo <- newEmptyMVar     _ <-         forkFinally             (processStandardOutput out)             (\_ -> putMVar vo ())      -- set up debug logger-    vl <- newEmptyMVar     _ <-         forkFinally             (processTelemetryMessages forwarder level out tel)@@ -612,7 +615,7 @@             Settings                 { ...                 }-    +     'changeProgram' settings program2  program2 :: 'Program' Settings ()@@ -680,7 +683,7 @@ to be enumerated separately:  @-    'execProcess' [\"\/usr\/bin\/ssh\", \"-l\", \"admin\", \"203.0.113.42\", \"\\\'remote command here\\\'\"]+    'readProcess' [\"\/usr\/bin\/ssh\", \"-l\", \"admin\", \"203.0.113.42\", \"\\\'remote command here\\\'\"] @  having to write out the individual options and arguments and deal with@@ -691,15 +694,17 @@ so if you're doing something that returns huge amounts of output you'll want to use something like __io-streams__ instead. -(this wraps __typed-process__'s 'readProcess')+(this wraps __typed-process__'s 'System.Process.Typed.readProcess')++@since 0.6.4 -}-execProcess :: [Rope] -> Program τ (ExitCode, Rope, Rope)-execProcess [] = error "No command provided"-execProcess (cmd : args) =+readProcess :: [Rope] -> Program τ (ExitCode, Rope, Rope)+readProcess [] = error "No command provided"+readProcess (cmd : args) =     let cmd' = fromRope cmd         args' = fmap fromRope args-        task = proc cmd' args'-        task1 = setStdin nullStream task+        task = Typed.proc cmd' args'+        task1 = Typed.setStdin Typed.nullStream task         command = mconcat (List.intersperse (singletonRope ' ') (cmd : args))     in  do             debug "command" command@@ -711,9 +716,68 @@                     Safe.throw (CommandNotFound cmd)                 Just _ -> do                     (exit, out, err) <- liftIO $ do-                        readProcess task1+                        Typed.readProcess task1                      pure (exit, intoRope out, intoRope err)++execProcess :: [Rope] -> Program τ (ExitCode, Rope, Rope)+execProcess = readProcess+{-# DEPRECATED execProcess "Use readProcess intead" #-}++{- |+Execute a new external binary, replacing this Haskell program in memory and+running the new binary in this program's place. The PID of the process does+not change.++This function does not return.++As with 'readProcess' above, each of the arguments to the new process+must be supplied as individual values in the list. The first argument is the+name of the binary to be executed. The @PATH@ will be searched for the binary+if an absolute path is not given; an exception will be thrown if it is not+found.++(this wraps __unix__'s 'executeFile' machinery, which results in an+/execvp(3)/ standard library function call)++@since 0.6.4+-}+execProcess_ :: [Rope] -> Program τ ()+execProcess_ [] = error "No command provided"+execProcess_ (cmd : args) = do+    context <- ask+    let cmd' = fromRope cmd+    let args' = fmap fromRope args+    let command = mconcat (List.intersperse (singletonRope ' ') (cmd : args))+    let vo = outputSemaphoreFrom context+    let out = outputChannelFrom context+    let vl = telemetrySemaphoreFrom context+    let tel = telemetryChannelFrom context++    debug "command" command++    probe <- liftIO $ do+        findExecutable cmd'+    case probe of+        Nothing -> do+            Safe.throw (CommandNotFound cmd)+        Just _ -> do+            liftIO $ do+                atomically $ do+                    writeTQueue tel Nothing+                    writeTQueue out Nothing++                _ <- forkIO $ do+                    threadDelay 10000000+                    putStrLn "error: Timeout"+                    Safe.throw (ExitFailure 97)++                readMVar vl+                readMVar vo++                -- does not return+                _ <- Posix.executeFile cmd' True args' Nothing+                pure ()  {- | Reset the start time (used to calculate durations shown in event- and