core-program 0.3.2.0 → 0.3.4.0

raw patch · 4 files changed

+221/−54 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 +62/−16
• lib/Core/Program/Execute.hs +139/−35
• lib/Core/Program/Logging.hs +19/−2

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

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}@@ -323,6 +324,18 @@ which ends with a full stop. For options that take values, use /upper case/ when specifying the label to be used in help output. +'Remaining' is special; it indicates that you are expecting a variable number+of additional, non-mandatory arguments. This is used for programs which take a+list of files to process, for example. It'll show up in the help with the+description you supply alongside.++@+        [ ...+        , 'Remaining' "The files you wish to delete permanently."+        , ...+        ]+@+ 'Variable' declares an /environment variable/ that, if present, will be read by the program and stored in its runtime context. By convention these are /upper case/. If the identifier is two or more words they are joined@@ -338,6 +351,7 @@ data Options     = Option LongName (Maybe ShortName) ParameterValue Description     | Argument LongName Description+    | Remaining Description     | Variable LongName Description  appendOption :: Options -> Config -> Config@@ -406,6 +420,7 @@ data Parameters = Parameters     { commandNameFrom :: Maybe LongName     , parameterValuesFrom :: Map LongName ParameterValue+    , remainingArgumentsFrom :: [String]     , environmentValuesFrom :: Map LongName ParameterValue     }     deriving (Show, Eq)@@ -415,6 +430,7 @@     Parameters         { commandNameFrom = Nothing         , parameterValuesFrom = emptyMap+        , remainingArgumentsFrom = []         , environmentValuesFrom = emptyMap         } @@ -535,22 +551,24 @@ -} parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters parseCommandLine config argv = case config of-    Blank -> return (Parameters Nothing emptyMap emptyMap)+    Blank -> return (Parameters Nothing emptyMap [] emptyMap)     Simple options -> do-        params <- extractor Nothing options argv-        return (Parameters Nothing params emptyMap)+        (params, remainder) <- extractor Nothing options argv+        checkRemainder options remainder+        return (Parameters Nothing params remainder emptyMap)     Complex commands ->         let globalOptions = extractGlobalOptions commands             modes = extractValidModes commands          in do                 (possibles, argv') <- splitCommandLine1 argv-                params1 <- extractor Nothing globalOptions possibles-                (first, remainingArgs) <- splitCommandLine2 argv'+                (params1, _) <- extractor Nothing globalOptions possibles+                (first, moreArgs) <- splitCommandLine2 argv'                 (mode, localOptions) <- parseIndicatedCommand modes first-                params2 <- extractor (Just mode) localOptions remainingArgs-                return (Parameters (Just mode) ((<>) params1 params2) emptyMap)+                (params2, remainder) <- extractor (Just mode) localOptions moreArgs+                checkRemainder localOptions remainder+                return (Parameters (Just mode) ((<>) params1 params2) remainder emptyMap)   where-    extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue)+    extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine ((Map LongName ParameterValue), [String])     extractor mode options args =         let (possibles, arguments) = List.partition isOption args             valids = extractValidNames options@@ -558,9 +576,29 @@             needed = extractRequiredArguments options          in do                 list1 <- parsePossibleOptions mode valids shorts possibles-                list2 <- parseRequiredArguments needed arguments-                return ((<>) (intoMap list1) (intoMap list2))+                (list2, arguments') <- parseRequiredArguments needed arguments+                pure (((<>) (intoMap list1) (intoMap list2)), arguments') +    checkRemainder :: [Options] -> [String] -> Either InvalidCommandLine ()+    checkRemainder options remainder =+        if List.null remainder+            then Right ()+            else+                if hasRemaining options+                    then Right ()+                    else Left (UnexpectedArguments remainder)++-- is one of the options Remaining?+hasRemaining :: [Options] -> Bool+hasRemaining options =+    List.foldl'+        ( \acc option -> case option of+            Remaining _ -> True+            _ -> acc+        )+        False+        options+ isOption :: String -> Bool isOption arg = case arg of     ('-' : _) -> True@@ -603,21 +641,20 @@ parseRequiredArguments ::     [LongName] ->     [String] ->-    Either InvalidCommandLine [(LongName, ParameterValue)]+    Either InvalidCommandLine ([(LongName, ParameterValue)], [String]) parseRequiredArguments needed argv = iter needed argv   where-    iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName, ParameterValue)]--    iter [] [] = Right []+    iter :: [LongName] -> [String] -> Either InvalidCommandLine ([(LongName, ParameterValue)], [String])+    iter [] [] = Right ([], [])     -- more arguments supplied than expected-    iter [] args = Left (UnexpectedArguments args)+    iter [] args = Right ([], args)     -- more arguments required, not satisfied     iter (name : _) [] = Left (MissingArgument name)     iter (name : names) (arg : args) =         let deeper = iter names args          in case deeper of                 Left e -> Left e-                Right list -> Right ((name, Value arg) : list)+                Right (list, remainder) -> Right (((name, Value arg) : list), remainder)  parseIndicatedCommand ::     Map LongName [Options] ->@@ -751,6 +788,7 @@                             [ pretty programName                             , optionsSummary o                             , argumentsSummary a+                            , remainingSummary a                             ]                         )                     )@@ -796,6 +834,7 @@                                     , commandSummary modes                                     , localSummary oL                                     , argumentsSummary aL+                                    , remainingSummary aL                                     ]                                 )                             )@@ -835,6 +874,9 @@      argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline else emptyDoc +    remainingSummary :: [Options] -> Doc ann+    remainingSummary as = if hasRemaining as then  " ..." else emptyDoc+     -- there is a corner case of complex config with no commands     commandSummary modes = if length modes > 0 then softline <> commandName else emptyDoc     commandHeading modes = if length modes > 0 then hardline <> "Available commands:" <> hardline else emptyDoc@@ -842,6 +884,7 @@     f :: Options -> ([Options], [Options]) -> ([Options], [Options])     f o@(Option _ _ _ _) (opts, args) = (o : opts, args)     f a@(Argument _ _) (opts, args) = (opts, a : args)+    f a@(Remaining _) (opts, args) = (opts, a : args)     f (Variable _ _) (opts, args) = (opts, args)      formatParameters :: [Options] -> Doc ann@@ -873,6 +916,9 @@         let l = pretty longname             d = fromRope description          in fillBreak 16 ("  " <> l <> " ") <+> align (reflow d) <> hardline <> acc+    g (Remaining description) acc =+        let d = fromRope description+         in fillBreak 16 ("  " <>  "... ") <+> align (reflow d) <> hardline <> acc     g (Variable longname description) acc =         let l = pretty longname             d = fromRope description

@@ -61,10 +61,11 @@      -- * Accessing program context     getCommandLine,-    lookupOptionFlag,-    lookupOptionValue,-    lookupArgument,-    lookupEnvironmentValue,+    queryOptionFlag,+    queryOptionValue,+    queryArgument,+    queryRemaining,+    queryEnvironmentValue,     getProgramName,     setProgramName,     getVerbosityLevel,@@ -94,8 +95,12 @@     unProgram,     unThread,     invalid,-    Boom(..),+    Boom (..),     loopForever,+    lookupOptionFlag,+    lookupOptionValue,+    lookupArgument,+    lookupEnvironmentValue, ) where  import Chrono.TimeStamp (getCurrentTimeNanoseconds)@@ -113,6 +118,7 @@     wait,  ) import Control.Concurrent.MVar (+    MVar,     modifyMVar_,     newMVar,     putMVar,@@ -150,7 +156,7 @@ import GHC.Conc (getNumProcessors, numCapabilities, setNumCapabilities) import GHC.IO.Encoding (setLocaleEncoding, utf8) import System.Directory (-    findExecutable+    findExecutable,  ) import System.Exit (ExitCode (..)) import qualified System.Posix.Process as Posix (exitImmediately)@@ -280,7 +286,7 @@     -- set up debug logger     l <-         Async.async $ do-            processTelemetryMessages forwarder out tel+            processTelemetryMessages forwarder level out tel      -- run actual program, ensuring to grab any otherwise uncaught exceptions.     code <-@@ -311,9 +317,12 @@         ( do             atomically $ do                 writeTQueue tel Nothing-                writeTQueue out Nothing              Async.wait l++            atomically $ do+                writeTQueue out Nothing+             Async.wait o         )         ( do@@ -356,17 +365,16 @@ -- the technique used   by **io-streams** to just pass along a stream of Maybes, -- with Nothing signalling end-of-stream is exactly good enough for our needs. ---processTelemetryMessages :: Forwarder -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> IO ()-processTelemetryMessages processor out tel = do+processTelemetryMessages :: Forwarder -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> IO ()+processTelemetryMessages processor v out tel = do     Safe.catch-        (loopForever action out tel)+        (loopForever action v out tel)         (collapseHandler "telemetry processing collapsed")   where     action = telemetryHandlerFrom processor -loopForever :: ([a] -> IO ()) -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO ()-loopForever action out queue = do-    start <- getCurrentTimeNanoseconds+loopForever :: ([a] -> IO ()) -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO ()+loopForever action v out queue = do     -- block waiting for an item     possibleItems <- atomically $ do         cycleOverQueue []@@ -376,20 +384,16 @@         Nothing -> pure ()         -- handle it and loop         Just items -> do+            start <- getCurrentTimeNanoseconds             catch-                (action (reverse items))+                ( do+                    action (reverse items)+                    reportStatus start (length items)+                )                 ( \(e :: SomeException) -> do-                    now <- getCurrentTimeNanoseconds-                    let result =-                            formatLogMessage-                                start-                                now-                                SeverityWarn-                                ("sending telemetry failed (Exception: " <> intoRope (show e) <> "); Restarting exporter.")-                    atomically $ do-                        writeTQueue out (Just result)+                    reportProblem start e                 )-            loopForever action out queue+            loopForever action v out queue   where     cycleOverQueue items =         case items of@@ -420,6 +424,35 @@                             Just item -> do                                 cycleOverQueue (item : items) +    reportStatus start num = do+        level <- readMVar v+        when (isDebug level) $ do+            now <- getCurrentTimeNanoseconds+            let desc = case num of+                    1 -> "1 event"+                    _ -> intoRope (show num) <> " events"+                message =+                    formatLogMessage+                        start+                        now+                        SeverityInternal+                        ("telemetry: sent " <> desc)+            atomically $ do+                writeTQueue out (Just message)++    reportProblem start e = do+        level <- readMVar v+        when (isEvent level) $ do+            now <- getCurrentTimeNanoseconds+            let message =+                    formatLogMessage+                        start+                        now+                        SeverityWarn+                        ("sending telemetry failed (Exception: " <> intoRope (show e) <> "); Restarting exporter.")+            atomically $ do+                writeTQueue out (Just message)+ {- | Safely exit the program with the supplied exit code. Current output and debug queues will be flushed, and then the process will terminate.@@ -752,8 +785,7 @@  This is available should you need to differentiate between a @Value@ and an @Empty@ 'ParameterValue', but for many cases as a convenience you can use the-'lookupOptionFlag', 'lookupOptionValue', and 'lookupArgument' functions below-(which are just wrappers around a code block like the example shown here).+'queryOptionFlag', 'queryOptionValue', and 'queryArgument' functions below. -} getCommandLine :: Program τ (Parameters) getCommandLine = do@@ -762,11 +794,24 @@  {- | Arguments are mandatory, so by the time your program is running a value-has already been identified. This returns the value for that parameter.+has already been identified. This retreives the value for that parameter.++@+program = do+    file <- 'queryArgument' \"filename\"+    ...+@ -}+queryArgument :: LongName -> Program τ Rope+queryArgument name = do+    context <- ask+    let params = commandLineFrom context+    case lookupKeyValue name (parameterValuesFrom params) of+        Nothing -> error "Attempted lookup of unconfigured argument"+        Just argument -> case argument of+            Empty -> error "Invalid State"+            Value value -> pure (intoRope value) --- this is Maybe because you can inadvertently ask for an unconfigured name--- this could be fixed with a much stronger Config type, potentially. lookupArgument :: LongName -> Parameters -> Maybe String lookupArgument name params =     case lookupKeyValue name (parameterValuesFrom params) of@@ -774,13 +819,48 @@         Just argument -> case argument of             Empty -> error "Invalid State"             Value value -> Just value+{-# DEPRECATED lookupArgument "Use queryArgument instead" #-}  {- |+In other applications, you want to gather up the remaining arguments on the+command-line. You need to have specified 'Remaining' in the configuration.++@+program = do+    files \<- 'queryRemaining'+    ...+@+-}+queryRemaining :: Program τ [Rope]+queryRemaining = do+    context <- ask+    let params = commandLineFrom context+    let remaining = remainingArgumentsFrom params+    pure (fmap intoRope remaining)++{- | Look to see if the user supplied a valued option and if so, what its value-was.+was. Use of the @LambdaCase@ extension might make accessing the parameter a+bit eaiser:++@+program = do+    count \<- 'queryOptionValue' \"count\" '>>=' \\case+        'Nothing' -> 'pure' 0+        'Just' value -> 'pure' value+    ...+@ -}+queryOptionValue :: LongName -> Program τ (Maybe Rope)+queryOptionValue name = do+    context <- ask+    let params = commandLineFrom context+    case lookupKeyValue name (parameterValuesFrom params) of+        Nothing -> pure Nothing+        Just argument -> case argument of+            Empty -> pure (Just emptyRope)+            Value value -> pure (Just (intoRope value)) --- Should this be more severe if it encounters Empty? lookupOptionValue :: LongName -> Parameters -> Maybe String lookupOptionValue name params =     case lookupKeyValue name (parameterValuesFrom params) of@@ -788,24 +868,47 @@         Just argument -> case argument of             Empty -> Nothing             Value value -> Just value+{-# DEPRECATED lookupOptionValue "Use queryOptionValue instead" #-}  {- |-Returns @Just True@ if the option is present, and @Nothing@ if it is not.+Returns @True@ if the option is present, and @False@ if it is not.++@+program = do+    overwrite \<- 'queryOptionValue' \"overwrite\"+    ...+@ -}+queryOptionFlag :: LongName -> Program τ Bool+queryOptionFlag name = do+    context <- ask+    let params = commandLineFrom context+    case lookupKeyValue name (parameterValuesFrom params) of+        Nothing -> pure False+        Just _ -> pure True --- The type is boolean to support a possible future extension of negated--- arguments. lookupOptionFlag :: LongName -> Parameters -> Maybe Bool lookupOptionFlag name params =     case lookupKeyValue name (parameterValuesFrom params) of         Nothing -> Nothing         Just argument -> case argument of             _ -> Just True -- nom, nom+{-# DEPRECATED lookupOptionFlag "Use queryOptionFlag instead" #-}  {- | Look to see if the user supplied the named environment variable and if so, return what its value was. -}+queryEnvironmentValue :: LongName -> Program τ (Maybe Rope)+queryEnvironmentValue name = do+    context <- ask+    let params = commandLineFrom context+    case lookupKeyValue name (environmentValuesFrom params) of+        Nothing -> error "Attempted lookup of unconfigured environment variable"+        Just param -> case param of+            Empty -> pure Nothing+            Value str -> pure (Just (intoRope str))+ lookupEnvironmentValue :: LongName -> Parameters -> Maybe String lookupEnvironmentValue name params =     case lookupKeyValue name (environmentValuesFrom params) of@@ -813,6 +916,7 @@         Just param -> case param of             Empty -> Nothing             Value str -> Just str+{-# DEPRECATED lookupEnvironmentValue "Use queryEnvironment instead" #-}  {- | Illegal internal state resulting from what should be unreachable code or

@@ -140,6 +140,11 @@     debug,     debugS,     debugR,++    -- internal+    internal,+    isEvent,+    isDebug, ) where  import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds)@@ -167,6 +172,7 @@     | SeverityWarn     | SeverityInfo     | SeverityDebug+    | SeverityInternal  putMessage :: Context τ -> Message -> IO () putMessage context (Message now level text possiblelValue) = do@@ -204,12 +210,13 @@         -- I hate doing math in Haskell         !elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3 -        !color = case severity of+        !colour = case severity of             SeverityNone -> emptyRope             SeverityCritical -> intoEscapes pureRed             SeverityWarn -> intoEscapes pureYellow             SeverityInfo -> intoEscapes dullWhite             SeverityDebug -> intoEscapes pureGrey+            SeverityInternal -> intoEscapes dullBlue          !reset = intoEscapes resetColour      in mconcat@@ -218,7 +225,7 @@             , " ("             , padWithZeros 6 (show elapsed)             , ") "-            , color+            , colour             , message             , reset             ]@@ -448,3 +455,13 @@             let value = render columns thing             !value' <- evaluate value             putMessage context (Message now SeverityDebug label (Just value'))++internal :: Rope -> Rope -> Program τ ()+internal label value = do+    context <- ask+    liftIO $ do+        level <- readMVar (verbosityLevelFrom context)+        when (isDebug level) $ do+            now <- getCurrentTimeNanoseconds+            !value' <- evaluate value+            putMessage context (Message now SeverityInternal (label <> value') Nothing)