core-program 0.3.4.1 → 0.4.0.0

raw patch · 5 files changed

+268/−103 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• core-program.cabal +2/−1
• lib/Core/Program.hs +2/−0
• lib/Core/Program/Arguments.hs +22/−22
• lib/Core/Program/Execute.hs +17/−80
• lib/Core/Program/Threads.hs +225/−0

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           core-program-version:        0.3.4.1+version:        0.4.0.0 synopsis:       Opinionated Haskell Interoperability description:    A library to help build command-line programs, both tools and                 longer-running daemons.@@ -42,6 +42,7 @@       Core.Program.Logging       Core.Program.Metadata       Core.Program.Notify+      Core.Program.Threads       Core.Program.Unlift       Core.System       Core.System.Base

@@ -21,6 +21,7 @@     -- and more.     module Core.Program.Context,     module Core.Program.Execute,+    module Core.Program.Threads,     module Core.Program.Unlift,     module Core.Program.Metadata, @@ -52,4 +53,5 @@ import Core.Program.Context import Core.Program.Metadata import Core.Program.Notify+import Core.Program.Threads import Core.Program.Unlift

@@ -172,14 +172,14 @@ \$ __./snippet --help__ Usage: -    snippet [OPTIONS] filename+    snippet [OPTIONS] <filename>  Available options:    -h, --host     Specify an alternate host to connect to when performing the                  frobnication. The default is \"localhost\".   -p, --port     Specify an alternate port to connect to when frobnicating.-      --dry-run=TIME+      --dry-run=<TIME>                  Perform a trial run at the specified time but don't                  actually do anything.   -q, --quiet    Supress normal output.@@ -189,7 +189,7 @@  Required arguments: -  filename       The file you want to frobnicate.+  <filename>     The file you want to frobnicate. \$ __|__ @ @@ -690,11 +690,11 @@  extractRequiredArguments :: [Options] -> [LongName] extractRequiredArguments arguments =-    foldr h [] arguments+    List.foldl' h [] arguments   where-    h :: Options -> [LongName] -> [LongName]-    h (Argument longname _) needed = longname : needed-    h _ needed = needed+    h :: [LongName] -> Options -> [LongName]+    h needed (Argument longname _) = longname : needed+    h needed _ = needed  extractGlobalOptions :: [Commands] -> [Options] extractGlobalOptions commands =@@ -870,12 +870,12 @@         Nothing -> "COMMAND..."      argumentsSummary :: [Options] -> Doc ann-    argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as))+    argumentsSummary as = " " <> fillSep (fmap (\x -> "<" <> pretty x <> ">") (extractRequiredArguments as))      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+    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@@ -889,7 +889,7 @@      formatParameters :: [Options] -> Doc ann     formatParameters [] = emptyDoc-    formatParameters options = hardline <> foldr g emptyDoc options+    formatParameters options = hardline <> List.foldl' g emptyDoc options      --     -- 16 characters width for short option, long option, and two spaces. If the@@ -900,8 +900,8 @@     -- pretty good and better than waiting until column 8.     -- -    g :: Options -> Doc ann -> Doc ann-    g (Option longname shortname valued description) acc =+    g :: Doc ann -> Options -> Doc ann+    g acc (Option longname shortname valued description) =         let s = case shortname of                 Just shortchar -> "  -" <> pretty shortchar <> ", --"                 Nothing -> "      --"@@ -911,28 +911,28 @@                 Empty ->                     fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc                 Value label ->-                    fillBreak 16 (s <> l <> "=" <> pretty label <> " ") <+> align (reflow d) <> hardline <> acc-    g (Argument longname description) acc =+                    fillBreak 16 (s <> l <> "=<" <> pretty label <> "> ") <+> align (reflow d) <> hardline <> acc+    g acc (Argument longname description) =         let l = pretty longname             d = fromRope description-         in fillBreak 16 ("  " <> l <> " ") <+> align (reflow d) <> hardline <> acc-    g (Remaining description) acc =+         in fillBreak 16 ("  <" <> l <> "> ") <+> align (reflow d) <> hardline <> acc+    g acc (Remaining description) =         let d = fromRope description-         in fillBreak 16 ("  " <>  "... ") <+> align (reflow d) <> hardline <> acc-    g (Variable longname description) acc =+         in fillBreak 16 ("  " <> "... ") <+> align (reflow d) <> hardline <> acc+    g acc (Variable longname description) =         let l = pretty longname             d = fromRope description          in fillBreak 16 ("  " <> l <> " ") <+> align (reflow d) <> hardline <> acc      formatCommands :: [Commands] -> Doc ann-    formatCommands commands = hardline <> foldr h emptyDoc commands+    formatCommands commands = hardline <> List.foldl' h emptyDoc commands -    h :: Commands -> Doc ann -> Doc ann-    h (Command longname description _) acc =+    h :: Doc ann -> Commands -> Doc ann+    h acc (Command longname description _) =         let l = pretty longname             d = fromRope description          in fillBreak 16 ("  " <> l <> " ") <+> align (reflow d) <> hardline <> acc-    h _ acc = acc+    h acc _ = acc  buildVersion :: Version -> Doc ann buildVersion version =

@@ -61,6 +61,7 @@      -- * Accessing program context     getCommandLine,+    queryCommandName,     queryOptionFlag,     queryOptionValue,     queryArgument,@@ -78,14 +79,8 @@     outputEntire,     inputEntire,     execProcess,--    -- * Concurrency-    Thread,-    forkThread,     sleepThread,     resetTimer,-    waitThread,-    waitThread_,     trap_,      -- * Internals@@ -93,7 +88,6 @@     None (..),     isNone,     unProgram,-    unThread,     invalid,     Boom (..),     loopForever,@@ -106,13 +100,11 @@ import Chrono.TimeStamp (getCurrentTimeNanoseconds) import Control.Concurrent (threadDelay) import Control.Concurrent.Async (-    Async,     ExceptionInLinkedThread (..),  ) import qualified Control.Concurrent.Async as Async (     async,     cancel,-    link,     race,     race_,     wait,@@ -120,7 +112,6 @@ import Control.Concurrent.MVar (     MVar,     modifyMVar_,-    newMVar,     putMVar,     readMVar,  )@@ -653,44 +644,8 @@                      pure (exit, intoRope out, intoRope err) -{- |-A thread for concurrent computation. Haskell uses green threads: small lines-of work that are scheduled down onto actual execution contexts, set by default-by this library to be one per core. They are incredibly lightweight, and you-are encouraged to use them freely. Haskell provides a rich ecosystem of tools-to do work concurrently and to communicate safely between threads -(this wraps __async__'s 'Async')--}-newtype Thread α = Thread (Async α)--unThread :: Thread α -> Async α-unThread (Thread a) = a- {- |-Fork a thread. The child thread will run in the same @Context@ as the calling-@Program@, including sharing the user-defined application state type.--(this wraps __async__'s 'async' which in turn wraps __base__'s-'Control.Concurrent.forkIO')--}-forkThread :: Program τ α -> Program τ (Thread α)-forkThread program = do-    context <- ask-    let i = startTimeFrom context--    liftIO $ do-        start <- readMVar i-        i' <- newMVar start--        let context' = context{startTimeFrom = i'}--        a <- Async.async $ do-            subProgram context' program-        Async.link a-        return (Thread a)--{- | Reset the start time (used to calculate durations shown in event- and debug-level logging) held in the @Context@ to zero. This is useful if you want to see the elapsed time taken by a specific worker rather than seeing log@@ -738,40 +693,6 @@      in liftIO $ threadDelay us  {- |-Wait for the completion of a thread, returning the result. This is a blocking-operation.--(this wraps __async__'s 'wait')--}-waitThread :: Thread α -> Program τ α-waitThread (Thread a) = liftIO $ Async.wait a--{- |-Wait for the completion of a thread, discarding its result. This is-particularly useful at the end of a do-block if you're waiting on a worker-thread to finish but don't need its return value, if any; otherwise you have-to explicily deal with the unused return value:--@-    _ <- 'waitThread' t1-    'return' ()-@--which is a bit tedious. Instead, you can just use this convenience function:--@-    'waitThread_' t1-@--The trailing underscore in the name of this function follows the same-convetion as found in "Control.Monad", which has 'Control.Monad.mapM_' which-does the same as 'Control.Monad.mapM' but which likewise discards the return-value.--}-waitThread_ :: Thread α -> Program τ ()-waitThread_ = void . waitThread--{- | Retrieve the values of parameters parsed from options and arguments supplied by the user on the command-line. @@ -929,6 +850,22 @@             Empty -> Nothing             Value str -> Just str {-# DEPRECATED lookupEnvironmentValue "Use queryEnvironment instead" #-}++{- |+Retreive the sub-command mode selected by the user. This assumes your program+was set up to take sub-commands via 'complexConfig'.++@+    mode <- queryCommandName+@+-}+queryCommandName :: Program τ Rope+queryCommandName = do+    context <- ask+    let params = commandLineFrom context+    case commandNameFrom params of+        Just (LongName name) -> pure (intoRope name)+        Nothing -> error "Attempted lookup of command but not a Complex Config"  {- | Illegal internal state resulting from what should be unreachable code or

@@ -0,0 +1,225 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK prune #-}++{- |+Utility functions for running 'Program' actions concurrently.++Haskell uses green threads: small lines of work that are scheduled down onto+actual execution contexts (set by default by this library to be one per core).+Haskell threads are incredibly lightweight, and you are encouraged to use them+freely. Haskell provides a rich ecosystem of tools to do work concurrently and+to communicate safely between threads.++This module provides wrappers around some of these primatives so you can use+them easily from the 'Program' monad.++Note that when you fire off a new thread the top-level application state is+/shared/; it's the same @τ@ inherited from the parent 'Program'.+-}+module Core.Program.Threads (+    -- * Concurrency+    forkThread,+    waitThread,+    waitThread_,++    -- * Helper functions+    concurrentThreads,+    concurrentThreads_,+    raceThreads,+    raceThreads_,++    -- * Internals+    Thread,+    unThread,+) where++import Control.Concurrent.Async (Async)+import qualified Control.Concurrent.Async as Async (+    async,+    concurrently,+    concurrently_,+    link,+    race,+    race_,+    wait,+ )+import Control.Concurrent.MVar (+    newMVar,+    readMVar,+ )+import Control.Monad (+    void,+ )+import Control.Monad.Reader.Class (MonadReader (ask))+import Core.Program.Context+import Core.System.Base++{- |+A thread for concurrent computation.++(this wraps __async__'s 'Async')+-}+newtype Thread α = Thread (Async α)++unThread :: Thread α -> Async α+unThread (Thread a) = a++{- |+Fork a thread. The child thread will run in the same @Context@ as the calling+@Program@, including sharing the user-defined application state value.++(this wraps __async__\'s 'Control.Concurrent.Async.async' which in turn wraps+__base__'s 'Control.Concurrent.forkIO')+-}+forkThread :: Program τ α -> Program τ (Thread α)+forkThread program = do+    context <- ask+    let i = startTimeFrom context++    liftIO $ do+        start <- readMVar i+        i' <- newMVar start++        let context' = context{startTimeFrom = i'}++        a <- Async.async $ do+            subProgram context' program+        Async.link a+        return (Thread a)++{- |+Wait for the completion of a thread, returning the result. This is a blocking+operation.++(this wraps __async__\'s 'wait')+-}+waitThread :: Thread α -> Program τ α+waitThread (Thread a) = liftIO $ Async.wait a++{- |+Wait for the completion of a thread, discarding its result. This is+particularly useful at the end of a do-block if you're waiting on a worker+thread to finish but don't need its return value, if any; otherwise you have+to explicily deal with the unused return value:++@+    _ <- 'waitThread' t1+    'return' ()+@++which is a bit tedious. Instead, you can just use this convenience function:++@+    'waitThread_' t1+@++The trailing underscore in the name of this function follows the same+convetion as found in "Control.Monad", which has 'Control.Monad.mapM_' which+does the same as 'Control.Monad.mapM' but which likewise discards the return+value.+-}+waitThread_ :: Thread α -> Program τ ()+waitThread_ = void . waitThread++{- |+Fork two threads and wait for both to finish. The return value is the pair of+each action's return types.++This is the same as calling 'forkThread' and 'waitThread' twice, except that+if either sub-program fails with an exception the other program which is still+running will be cancelled and the original exception is then re-thrown.++@+    (a,b) <- 'concurrentThreads' one two++    -- continue, doing something with both results.+@++For a variant that ingores the return values and just waits for both see+'concurrentThreads_' below.++(this wraps __async__\'s 'Control.Concurrent.Async.concurrently')+-}+concurrentThreads :: Program τ α -> Program τ β -> Program τ (α, β)+concurrentThreads one two = do+    context <- ask+    liftIO $ do+        Async.concurrently+            (subProgram context one)+            (subProgram context two)++{- |+Fork two threads and wait for both to finish.++This is the same as calling 'forkThread' and 'waitThread_' twice, except that+if either sub-program fails with an exception the other program which is still+running will be cancelled and the original exception is then re-thrown.++(this wraps __async__\'s 'Control.Concurrent.Async.concurrently_')+-}+concurrentThreads_ :: Program τ α -> Program τ β -> Program τ ()+concurrentThreads_ one two = do+    context <- ask+    liftIO $ do+        Async.concurrently_+            (subProgram context one)+            (subProgram context two)++{- |+Fork two threads and race them against each other. This blocks until one or+the other of the threads finishes. The return value will be 'Left' @α@ if the+first program (@one@) completes first, and 'Right' @β@ if it is the second+program (@two@) which finishes first. The sub program which is still running+will be cancelled with an exception.++@+    result <- 'raceThreads' one two+    case result of+        Left a -> do+            -- one finished first+        Right b -> do+            -- two finished first+@++For a variant that ingores the return value and just races the threads see+'raceThreads_' below.++(this wraps __async__\'s 'Control.Concurrent.Async.race')+-}+raceThreads :: Program τ α -> Program τ β -> Program τ (Either α β)+raceThreads one two = do+    context <- ask+    liftIO $ do+        Async.race+            (subProgram context one)+            (subProgram context two)++{- |+Fork two threads and race them against each other. When one action completes+the other will be cancelled with an exception. This is useful for enforcing+timeouts:++@+    'raceThreads_'+        ('sleepThread' 300)+        (do+            -- We expect this to complete within 5 minutes.+            performAction+        )+@++(this wraps __async__\'s 'Control.Concurrent.Async.race_')+-}+raceThreads_ :: Program τ α -> Program τ β -> Program τ ()+raceThreads_ one two = do+    context <- ask+    liftIO $ do+        Async.race_+            (subProgram context one)+            (subProgram context two)