core-program 0.6.1.1 → 0.6.2.1
raw patch · 16 files changed
+524/−475 lines, 16 filesdep +unliftio-corePVP ok
version bump matches the API change (PVP)
Dependencies added: unliftio-core
API changes (from Hackage documentation)
+ Core.Program.Execute: queryEnvironmentValue' :: Externalize ξ => LongName -> Program τ (Maybe ξ)
Files
- core-program.cabal +3/−2
- lib/Core/Program.hs +38/−38
- lib/Core/Program/Arguments.hs +75/−73
- lib/Core/Program/Context.hs +38/−25
- lib/Core/Program/Exceptions.hs +24/−24
- lib/Core/Program/Execute.hs +133/−101
- lib/Core/Program/Logging.hs +23/−23
- lib/Core/Program/Metadata.hs +12/−12
- lib/Core/Program/Notify.hs +44/−45
- lib/Core/Program/Signal.hs +10/−10
- lib/Core/Program/Threads.hs +25/−25
- lib/Core/Program/Unlift.hs +12/−10
- lib/Core/System.hs +21/−21
- lib/Core/System/Base.hs +24/−25
- lib/Core/System/External.hs +2/−1
- lib/Core/System/Pretty.hs +40/−40
core-program.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: core-program-version: 0.6.1.1+version: 0.6.2.1 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons.@@ -76,4 +76,5 @@ , transformers , typed-process , unix+ , unliftio-core default-language: Haskell2010
lib/Core/Program.hs view
@@ -2,50 +2,50 @@ -- actually, they're there to group implementation too, but hey. --- |--- Support for building command-line programs, ranging from simple tools to--- long-running daemons.------ This is intended to be used directly:------ @--- import "Core.Program"--- @------ the submodules are mostly there to group documentation.-module Core.Program- ( -- * Executing a program+{- |+Support for building command-line programs, ranging from simple tools to+long-running daemons. - -- |- -- A top-level Program type giving you unified access to logging, concurrency,- -- and more.- module Core.Program.Context,- module Core.Program.Execute,- module Core.Program.Threads,- module Core.Program.Unlift,- module Core.Program.Metadata,- module Core.Program.Exceptions,+This is intended to be used directly: - -- * Command-line argument parsing+@+import "Core.Program"+@ - -- |- -- Including declaring what options your program accepts, generating help, and- -- for more complex cases [sub]commands, mandatory arguments, and environment- -- variable handling.- module Core.Program.Arguments,+the submodules are mostly there to group documentation.+-}+module Core.Program+ ( -- * Executing a program - -- * Logging facilities+ -- |+ -- A top-level Program type giving you unified access to logging, concurrency,+ -- and more.+ module Core.Program.Context+ , module Core.Program.Execute+ , module Core.Program.Threads+ , module Core.Program.Unlift+ , module Core.Program.Metadata+ , module Core.Program.Exceptions - -- |- -- Facilities for noting events through your program and doing debugging.- module Core.Program.Logging,+ -- * Command-line argument parsing - -- |- -- There are a few common use cases which require a bit of wrapping to use- -- effectively. Watching files for changes and taking action in the event of a- -- change is one.- module Core.Program.Notify,- )+ -- |+ -- Including declaring what options your program accepts, generating help, and+ -- for more complex cases [sub]commands, mandatory arguments, and environment+ -- variable handling.+ , module Core.Program.Arguments++ -- * Logging facilities++ -- |+ -- Facilities for noting events through your program and doing debugging.+ , module Core.Program.Logging+ -- |+ -- There are a few common use cases which require a bit of wrapping to use+ -- effectively. Watching files for changes and taking action in the event of a+ -- change is one.+ , module Core.Program.Notify+ ) where import Core.Program.Arguments
lib/Core/Program/Arguments.hs view
@@ -20,53 +20,53 @@ Additionally, this module allows you to specify environment variables that, if present, will be incorporated into the stored configuration. -}-module Core.Program.Arguments (- -- * Setup- Config,- blankConfig,- simpleConfig,- complexConfig,- baselineOptions,- Parameters (..),- ParameterValue (..),+module Core.Program.Arguments+ ( -- * Setup+ Config+ , blankConfig+ , simpleConfig+ , complexConfig+ , baselineOptions+ , Parameters (..)+ , ParameterValue (..) - -- * Options and Arguments- LongName (..),- ShortName,- Description,- Options (..),+ -- * Options and Arguments+ , LongName (..)+ , ShortName+ , Description+ , Options (..) - -- * Programs with Commands- Commands (..),- appendOption,+ -- * Programs with Commands+ , Commands (..)+ , appendOption - -- * Internals- parseCommandLine,- extractValidEnvironments,- InvalidCommandLine (..),- buildUsage,- buildVersion,- emptyParameters,-) where+ -- * Internals+ , parseCommandLine+ , extractValidEnvironments+ , InvalidCommandLine (..)+ , buildUsage+ , buildVersion+ , emptyParameters+ ) where import Data.Hashable (Hashable) import Data.List qualified as List import Data.Maybe (fromMaybe) import Data.String (IsString (..))-import Prettyprinter (- Doc,- Pretty (..),- align,- emptyDoc,- fillBreak,- fillCat,- fillSep,- hardline,- indent,- nest,- softline,- (<+>),- )+import Prettyprinter+ ( Doc+ , Pretty (..)+ , align+ , emptyDoc+ , fillBreak+ , fillCat+ , fillSep+ , hardline+ , indent+ , nest+ , softline+ , (<+>)+ ) import Prettyprinter.Util (reflow) import System.Environment (getProgName) @@ -498,12 +498,12 @@ For options valid in this program, please see --help. |]- in one ++ two+ in one ++ two UnknownOption name -> "Sorry, option '" ++ name ++ "' not recognized." MissingArgument (LongName name) -> "Mandatory argument '" ++ name ++ "' missing." UnexpectedArguments args -> let quoted = List.intercalate "', '" args- in [quote|+ in [quote| Unexpected trailing arguments: |]@@ -557,7 +557,7 @@ Complex commands -> let globalOptions = extractGlobalOptions commands modes = extractValidModes commands- in do+ in do (possibles, argv') <- splitCommandLine1 argv (params1, _) <- extractor Nothing globalOptions possibles (first, moreArgs) <- splitCommandLine2 argv'@@ -572,7 +572,7 @@ valids = extractValidNames options shorts = extractShortNames options needed = extractRequiredArguments options- in do+ in do list1 <- parsePossibleOptions mode valids shorts possibles (list2, arguments') <- parseRequiredArguments needed arguments pure (((<>) (intoMap list1) (intoMap list2)), arguments')@@ -602,12 +602,12 @@ ('-' : _) -> True _ -> False -parsePossibleOptions ::- Maybe LongName ->- Set LongName ->- Map ShortName LongName ->- [String] ->- Either InvalidCommandLine [(LongName, ParameterValue)]+parsePossibleOptions+ :: Maybe LongName+ -> Set LongName+ -> Map ShortName LongName+ -> [String]+ -> Either InvalidCommandLine [(LongName, ParameterValue)] parsePossibleOptions mode valids shorts args = mapM f args where f arg = case arg of@@ -626,7 +626,7 @@ value' = case List.uncons value of Just (_, remainder) -> Value remainder Nothing -> Empty- in if containsElement candidate valids+ in if containsElement candidate valids then Right (candidate, value') else Left (UnknownOption ("--" ++ name)) @@ -636,10 +636,10 @@ Just name -> Right (name, Empty) Nothing -> Left (UnknownOption ['-', c]) -parseRequiredArguments ::- [LongName] ->- [String] ->- Either InvalidCommandLine ([(LongName, ParameterValue)], [String])+parseRequiredArguments+ :: [LongName]+ -> [String]+ -> Either InvalidCommandLine ([(LongName, ParameterValue)], [String]) parseRequiredArguments needed argv = iter needed argv where iter :: [LongName] -> [String] -> Either InvalidCommandLine ([(LongName, ParameterValue)], [String])@@ -650,17 +650,17 @@ iter (name : _) [] = Left (MissingArgument name) iter (name : names) (arg : args) = let deeper = iter names args- in case deeper of+ in case deeper of Left e -> Left e Right (list, remainder) -> Right (((name, Value arg) : list), remainder) -parseIndicatedCommand ::- Map LongName [Options] ->- String ->- Either InvalidCommandLine (LongName, [Options])+parseIndicatedCommand+ :: Map LongName [Options]+ -> String+ -> Either InvalidCommandLine (LongName, [Options]) parseIndicatedCommand modes first = let candidate = LongName first- in case lookupKeyValue candidate modes of+ in case lookupKeyValue candidate modes of Just options -> Right (candidate, options) Nothing -> Left (UnknownCommand first) @@ -722,14 +722,14 @@ splitCommandLine1 :: [String] -> Either InvalidCommandLine ([String], [String]) splitCommandLine1 args = let (possibles, remainder) = List.span isOption args- in if null possibles && null remainder+ in if null possibles && null remainder then Left NoCommandFound else Right (possibles, remainder) splitCommandLine2 :: [String] -> Either InvalidCommandLine (String, [String]) splitCommandLine2 argv' = let x = List.uncons argv'- in case x of+ in case x of Just (mode, remainingArgs) -> Right (mode, remainingArgs) Nothing -> Left NoCommandFound @@ -747,7 +747,7 @@ locals = extractLocalVariables commands (fromMaybe "" mode) variables2 = extractVariableNames locals- in variables1 <> variables2+ in variables1 <> variables2 extractLocalVariables :: [Commands] -> LongName -> [Options] extractLocalVariables commands mode =@@ -777,7 +777,9 @@ Blank -> emptyDoc Simple options -> let (o, a, v) = partitionParameters options- in "Usage:" <> hardline <> hardline+ in "Usage:"+ <> hardline+ <> hardline <> indent 4 ( nest@@ -802,7 +804,7 @@ modes = extractValidModes commands (oG, _, vG) = partitionParameters globalOptions- in "Usage:" <> hardline <> hardline <> case mode of+ in "Usage:" <> hardline <> hardline <> case mode of Nothing -> indent 2@@ -826,7 +828,7 @@ let (oL, aL, vL) = case lookupKeyValue longname modes of Just localOptions -> partitionParameters localOptions Nothing -> error "Illegal State"- in indent+ in indent 2 ( nest 4@@ -913,7 +915,7 @@ Nothing -> " --" l = pretty longname d = fromRope description- in case valued of+ in case valued of Empty -> fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc Value label ->@@ -921,14 +923,14 @@ g acc (Argument longname description) = let l = pretty longname d = fromRope description- in fillBreak 16 (" <" <> l <> "> ") <+> align (reflow d) <> hardline <> 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+ 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+ in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc formatCommands :: [Commands] -> Doc ann formatCommands commands = hardline <> List.foldl' h emptyDoc commands@@ -937,12 +939,12 @@ h acc (Command longname description _) = let l = pretty longname d = fromRope description- in acc <> fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline+ in acc <> fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline h acc _ = acc buildVersion :: Version -> Doc ann buildVersion version = pretty (projectNameFrom version) <+> "v"- <> pretty (versionNumberFrom version)- <> hardline+ <> pretty (versionNumberFrom version)+ <> hardline
lib/Core/Program/Context.hs view
@@ -13,29 +13,29 @@ {-# OPTIONS_HADDOCK hide #-} -- This is an Internal module, hidden from Haddock-module Core.Program.Context (- Datum (..),- emptyDatum,- Trace (..),- unTrace,- Span (..),- unSpan,- Context (..),- handleCommandLine,- handleVerbosityLevel,- handleTelemetryChoice,- Exporter (..),- Forwarder (..),- None (..),- isNone,- configure,- Verbosity (..),- Program (..),- unProgram,- getContext,- fmapContext,- subProgram,-) where+module Core.Program.Context+ ( Datum (..)+ , emptyDatum+ , Trace (..)+ , unTrace+ , Span (..)+ , unSpan+ , Context (..)+ , handleCommandLine+ , handleVerbosityLevel+ , handleTelemetryChoice+ , Exporter (..)+ , Forwarder (..)+ , None (..)+ , isNone+ , configure+ , Verbosity (..)+ , Program (..)+ , unProgram+ , getContext+ , fmapContext+ , subProgram+ ) where import Control.Concurrent (ThreadId) import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar)@@ -43,6 +43,7 @@ import Control.Concurrent.STM.TVar (TVar, newTVarIO) import Control.Exception.Safe qualified as Safe (throw) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow (throwM))+import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO)) import Control.Monad.Reader.Class (MonadReader (..)) import Control.Monad.Trans.Reader (ReaderT (..)) import Core.Data.Clock@@ -198,7 +199,7 @@ state <- readMVar (applicationDataFrom context) let state' = f state u <- newMVar state'- return (context{applicationDataFrom = u})+ return (context {applicationDataFrom = u}) {- | A 'Program' with no user-supplied state to be threaded throughout the@@ -318,6 +319,18 @@ subProgram context (Program r) = do runReaderT r context +--+-- This isn't needed by our packages, but it's a useful instance. This is a+-- copy of what is in Core.Program.Unlift.withContext. I would have put this+-- there, but it leaves an orphan.+--+instance MonadUnliftIO (Program τ) where+ {-# INLINE withRunInIO #-}+ withRunInIO action = do+ context <- getContext+ liftIO $ do+ action (subProgram context)+ {- This is complicated. The **safe-exceptions** library exports a `throwM` which is not the `throwM` class method from MonadThrow. See@@ -487,7 +500,7 @@ queryVerbosityLevel params = let debug = lookupKeyValue "debug" (parameterValuesFrom params) verbose = lookupKeyValue "verbose" (parameterValuesFrom params)- in case debug of+ in case debug of Just value -> case value of Empty -> Right Debug Value "internal" -> Right Internal
lib/Core/Program/Exceptions.hs view
@@ -72,30 +72,30 @@ back to the surface (in our case the 'Program' @τ@ monad) and you can 'throw' from there. -}-module Core.Program.Exceptions (- catch,- try,- throw,- bracket,- finally,- onException,- Boom (..),-) where+module Core.Program.Exceptions+ ( catch+ , try+ , throw+ , bracket+ , finally+ , onException+ , Boom (..)+ ) where -import Control.Exception qualified as Base (- Exception,- )-import Control.Exception.Safe qualified as Safe (- bracket,- catch,- finally,- onException,- throw,- try,- )-import Core.Program.Context (- Program,- )+import Control.Exception qualified as Base+ ( Exception+ )+import Control.Exception.Safe qualified as Safe+ ( bracket+ , catch+ , finally+ , onException+ , throw+ , try+ )+import Core.Program.Context+ ( Program+ ) {- | Catch an exception.@@ -188,7 +188,7 @@ @ 22:54:39Z (00.002) SomeoneWrongOnInternet \"Ashley thinks there are more than three Star Wars movies\"-$+\$ @ but if you're in a hurry and don't want to define a local exception type to
lib/Core/Program/Execute.hs view
@@ -49,98 +49,100 @@ arguments you can initialize your program using 'configure' and then run with 'executeWith'. -}-module Core.Program.Execute (- Program (),+module Core.Program.Execute+ ( Program () - -- * Running programs- configure,- execute,- executeWith,+ -- * Running programs+ , configure+ , execute+ , executeWith - -- * Exiting a program- terminate,+ -- * Exiting a program+ , terminate - -- * Accessing program context- getCommandLine,- queryCommandName,- queryOptionFlag,- queryOptionValue,- queryOptionValue',- queryArgument,- queryRemaining,- queryEnvironmentValue,- getProgramName,- setProgramName,- getVerbosityLevel,- setVerbosityLevel,- getConsoleWidth,- getApplicationState,- setApplicationState,+ -- * Accessing program context+ , getCommandLine+ , queryCommandName+ , queryOptionFlag+ , queryOptionValue+ , queryOptionValue'+ , queryArgument+ , queryRemaining+ , queryEnvironmentValue+ , queryEnvironmentValue'+ , getProgramName+ , setProgramName+ , getVerbosityLevel+ , setVerbosityLevel+ , getConsoleWidth+ , getApplicationState+ , setApplicationState - -- * Useful actions- outputEntire,- inputEntire,- execProcess,- sleepThread,- resetTimer,- trap_,+ -- * Useful actions+ , outputEntire+ , inputEntire+ , execProcess+ , sleepThread+ , resetTimer+ , trap_ - -- * Exception handling- catch,- throw,- try,+ -- * Exception handling+ , catch+ , throw+ , try - -- * Internals- Context,- None (..),- isNone,- unProgram,- invalid,- Boom (..),- loopForever,- lookupOptionFlag,- lookupOptionValue,- lookupArgument,- lookupEnvironmentValue,-) where+ -- * Internals+ , Context+ , None (..)+ , isNone+ , unProgram+ , invalid+ , Boom (..)+ , loopForever+ , lookupOptionFlag+ , lookupOptionValue+ , lookupArgument+ , lookupEnvironmentValue+ )+where -import Control.Concurrent (- forkFinally,- forkIO,- killThread,- myThreadId,- threadDelay,- )-import Control.Concurrent.MVar (- MVar,- modifyMVar_,- newEmptyMVar,- putMVar,- readMVar,- tryPutMVar,- )+import Control.Concurrent+ ( forkFinally+ , forkIO+ , killThread+ , myThreadId+ , threadDelay+ )+import Control.Concurrent.MVar+ ( MVar+ , modifyMVar_+ , newEmptyMVar+ , putMVar+ , readMVar+ , tryPutMVar+ ) import Control.Concurrent.STM (atomically)-import Control.Concurrent.STM.TQueue (- TQueue,- readTQueue,- tryReadTQueue,- unGetTQueue,- writeTQueue,- )-import Control.Concurrent.STM.TVar (- readTVarIO,- )+import Control.Concurrent.STM.TQueue+ ( TQueue+ , readTQueue+ , tryReadTQueue+ , unGetTQueue+ , writeTQueue+ )+import Control.Concurrent.STM.TVar+ ( readTVarIO+ ) import Control.Exception qualified as Base (throwIO)-import Control.Exception.Safe qualified as Safe (- catch,- throw,- )-import Control.Monad (- forM_,- forever,- void,- when,- )+import Control.Exception.Safe qualified as Safe+ ( catch+ , throw+ )+import Control.Monad+ ( forM_+ , forever+ , void+ , when+ ) import Control.Monad.Reader.Class (MonadReader (ask)) import Core.Data.Clock import Core.Data.Structures@@ -150,15 +152,15 @@ import Core.Program.Exceptions import Core.Program.Logging import Core.Program.Signal-import Core.System.Base (- Exception,- Handle,- SomeException,- displayException,- hFlush,- liftIO,- stdout,- )+import Core.System.Base+ ( Exception+ , Handle+ , SomeException+ , displayException+ , hFlush+ , liftIO+ , stdout+ ) import Core.Text.Bytes import Core.Text.Rope import Data.ByteString qualified as B (hPut)@@ -166,9 +168,9 @@ import Data.List qualified as List (intersperse) import GHC.Conc (getNumProcessors, numCapabilities, setNumCapabilities) import GHC.IO.Encoding (setLocaleEncoding, utf8)-import System.Directory (- findExecutable,- )+import System.Directory+ ( findExecutable+ ) import System.Exit (ExitCode (..)) import System.Process.Typed (nullStream, proc, readProcess, setStdin) import Prelude hiding (log)@@ -203,7 +205,7 @@ (void action) ( \(e :: SomeException) -> let text = intoRope (displayException e)- in do+ in do warn "Trapped uncaught exception" debug "e" text )@@ -637,7 +639,7 @@ task = proc cmd' args' task1 = setStdin nullStream task command = mconcat (List.intersperse (singletonRope ' ') (cmd : args))- in do+ in do debug "command" command probe <- liftIO $ do@@ -698,7 +700,7 @@ sleepThread :: Rational -> Program τ () sleepThread seconds = let us = floor (toRational (seconds * 1e6))- in liftIO $ threadDelay us+ in liftIO $ threadDelay us {- | Retrieve the values of parameters parsed from options and arguments supplied@@ -824,13 +826,17 @@ data QueryParameterError = OptionValueMissing LongName- | UnableParseValue LongName+ | UnableParseOption LongName+ | EnvironmentVariableMissing LongName+ | UnableParseVariable LongName deriving (Show) instance Exception QueryParameterError where displayException e = case e of OptionValueMissing (LongName name) -> "Option --" ++ name ++ " specified but without a value."- UnableParseValue (LongName name) -> "Unable to parse the value supplied to --" ++ name ++ "."+ UnableParseOption (LongName name) -> "Unable to parse the value supplied to --" ++ name ++ "."+ EnvironmentVariableMissing (LongName name) -> "Variable " ++ name ++ " requested but is unset."+ UnableParseVariable (LongName name) -> "Unable to parse the value present in " ++ name ++ "." {- | Look to see if the user supplied a valued option and if so, what its value@@ -869,7 +875,7 @@ Just parameter -> case parameter of Empty -> throw (OptionValueMissing name) Value value -> case parseExternal (packRope value) of- Nothing -> throw (UnableParseValue name)+ Nothing -> throw (UnableParseOption name) Just actual -> pure (Just actual) {- |@@ -914,6 +920,32 @@ Just param -> case param of Empty -> pure Nothing Value str -> pure (Just (intoRope str))++{- |+Look to see if the user supplied the named environment variable and if so,+return what its value was.++Like 'queryOptionValue'' above, this function attempts to parse the supplied+value as 'Just' the inferred type. This makes the assumption that the+requested environment variable is populated. If it is not set in the+environment, or is set to the empty string, then this function will return+'Nothing'.++If the attempt to parse the supplied value fails an exception will be thrown.++@since 0.6.2+-}+queryEnvironmentValue' :: Externalize ξ => LongName -> Program τ (Maybe ξ)+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 value -> case parseExternal (packRope value) of+ Nothing -> throw (UnableParseVariable name)+ Just actual -> pure (Just actual) lookupEnvironmentValue :: LongName -> Parameters -> Maybe String lookupEnvironmentValue name params =
lib/Core/Program/Logging.hs view
@@ -121,32 +121,32 @@ \$ @ -}-module Core.Program.Logging (- putMessage,- formatLogMessage,- Severity (..),- Verbosity (..),+module Core.Program.Logging+ ( putMessage+ , formatLogMessage+ , Severity (..)+ , Verbosity (..) - -- * Normal output- write,- writeS,- writeR,+ -- * Normal output+ , write+ , writeS+ , writeR - -- * Informational- info,- warn,- critical,+ -- * Informational+ , info+ , warn+ , critical - -- * Debugging- debug,- debugS,- debugR,+ -- * Debugging+ , debug+ , debugS+ , debugR -- internal- internal,- isEvent,- isDebug,- isInternal,-) where+ , internal+ , isEvent+ , isDebug+ , isInternal+ ) where import Control.Concurrent.MVar (readMVar) import Control.Concurrent.STM (atomically)@@ -221,7 +221,7 @@ SeverityInternal -> intoEscapes dullBlue !reset = intoEscapes resetColour- in case coloured of+ in case coloured of True -> mconcat [ intoEscapes dullWhite
lib/Core/Program/Metadata.hs view
@@ -8,18 +8,18 @@ Digging metadata out of the description of your project, and other useful helpers. -}-module Core.Program.Metadata (- Version,- versionNumberFrom,- projectNameFrom,- projectSynopsisFrom,+module Core.Program.Metadata+ ( Version+ , versionNumberFrom+ , projectNameFrom+ , projectSynopsisFrom - -- * Splice- fromPackage,+ -- * Splice+ , fromPackage - -- * Source code- __LOCATION__,-) where+ -- * Source code+ , __LOCATION__+ ) where import Core.Data import Core.System.Base (IOMode (..), withFile)@@ -66,7 +66,7 @@ emptyVersion = Version "" "" "0" instance IsString Version where- fromString x = emptyVersion{versionNumberFrom = x}+ fromString x = emptyVersion {versionNumberFrom = x} {- | This is a splice which includes key built-time metadata, including the number@@ -154,7 +154,7 @@ parseCabalFile :: Bytes -> Map Rope Rope parseCabalFile contents = let breakup = intoMap . fmap (\(a, b) -> (a, trimValue b)) . fmap (breakRope (== ':')) . breakLines . fromBytes- in breakup contents+ in breakup contents -- knock off the colon and whitespace in ": hello" trimValue :: Rope -> Rope
lib/Core/Program/Notify.hs view
@@ -5,10 +5,9 @@ Helpers for watching files for changes and taking action in the event of a change. -}-module Core.Program.Notify (- -- * Notify- waitForChange,-) where+module Core.Program.Notify+ ( waitForChange+ ) where import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) import Control.Monad.IO.Class (liftIO)@@ -40,50 +39,50 @@ -- waitForChange :: [FilePath] -> Program τ () waitForChange files =- let f :: FilePath -> Set FilePath -> Set FilePath- f path acc = insertElement path acc+ let f :: FilePath -> Set FilePath -> Set FilePath+ f path acc = insertElement path acc - g :: FilePath -> Set FilePath -> Set FilePath- g path acc = insertElement (dropFileName path) acc- in do- info "Watching for changes"+ g :: FilePath -> Set FilePath -> Set FilePath+ g path acc = insertElement (dropFileName path) acc+ in do+ info "Watching for changes" - canonical <- mapM (liftIO . canonicalizePath) files- let paths = foldr f emptySet canonical- let dirs = foldr g emptySet files+ canonical <- mapM (liftIO . canonicalizePath) files+ let paths = foldr f emptySet canonical+ let dirs = foldr g emptySet files - withContext $ \runProgram -> do- block <- newEmptyMVar- withManager $ \manager -> do- -- setup watches- stoppers <-- foldrM- ( \dir acc -> do- runProgram (debugS "watching" dir)- stopper <-- watchDir- manager- dir- ( \trigger -> case trigger of- Modified file _ _ -> do- if containsElement file paths- then True- else False- _ -> False- )- ( \trigger -> do- runProgram (debugS "trigger" (eventPath trigger))- putMVar block False- )- return (stopper : acc)- )- []- dirs+ withContext $ \runProgram -> do+ block <- newEmptyMVar+ withManager $ \manager -> do+ -- setup watches+ stoppers <-+ foldrM+ ( \dir acc -> do+ runProgram (debugS "watching" dir)+ stopper <-+ watchDir+ manager+ dir+ ( \trigger -> case trigger of+ Modified file _ _ -> do+ if containsElement file paths+ then True+ else False+ _ -> False+ )+ ( \trigger -> do+ runProgram (debugS "trigger" (eventPath trigger))+ putMVar block False+ )+ return (stopper : acc)+ )+ []+ dirs - -- wait- _ <- readMVar block+ -- wait+ _ <- readMVar block - sequence_ stoppers- return ()+ sequence_ stoppers+ return () - sleepThread 0.1+ sleepThread 0.1
lib/Core/Program/Signal.hs view
@@ -1,21 +1,21 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -module Core.Program.Signal (- setupSignalHandlers,-) where+module Core.Program.Signal+ ( setupSignalHandlers+ ) where import Control.Concurrent.MVar (MVar, modifyMVar_, putMVar) import Core.Program.Context import Foreign.C.Types (CInt) import System.Exit (ExitCode (..)) import System.IO (hFlush, hPutStrLn, stdout)-import System.Posix.Signals (- Handler (Catch),- installHandler,- sigINT,- sigTERM,- sigUSR1,- )+import System.Posix.Signals+ ( Handler (Catch)+ , installHandler+ , sigINT+ , sigTERM+ , sigUSR1+ ) {- | Make a non-zero exit code which is 0b1000000 + the number of the signal.
lib/Core/Program/Threads.hs view
@@ -23,39 +23,39 @@ 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- createScope,- forkThread,- forkThread_,- linkThread,- waitThread,- waitThread_,- waitThread',- waitThreads',- cancelThread,+module Core.Program.Threads+ ( -- * Concurrency+ createScope+ , forkThread+ , forkThread_+ , linkThread+ , waitThread+ , waitThread_+ , waitThread'+ , waitThreads'+ , cancelThread - -- * Helper functions- concurrentThreads,- concurrentThreads_,- raceThreads,- raceThreads_,+ -- * Helper functions+ , concurrentThreads+ , concurrentThreads_+ , raceThreads+ , raceThreads_ - -- * Internals- Thread,- unThread,-) where+ -- * Internals+ , Thread+ , unThread+ ) where import Control.Concurrent (ThreadId, forkIO, killThread) import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVarIO) import Control.Exception.Safe qualified as Safe (catch, finally, onException, throw)-import Control.Monad (- forM,- forM_,- void,- )+import Control.Monad+ ( forM+ , forM_+ , void+ ) import Control.Monad.Reader.Class (MonadReader (ask)) import Core.Data.Structures import Core.Program.Context
lib/Core/Program/Unlift.hs view
@@ -93,14 +93,14 @@ you're having trouble with the types try putting @return ()@ at the end of your subprogram. -}-module Core.Program.Unlift (- -- * Unlifting- withContext,+module Core.Program.Unlift+ ( -- * Unlifting+ withContext - -- * Internals- getContext,- subProgram,-) where+ -- * Internals+ , getContext+ , subProgram+ ) where import Core.Program.Context import Core.Program.Execute@@ -145,15 +145,17 @@ -- now in Program monad ... @++Note there is a 'MonadUnliftIO' instance which may be useful to you as well. -} -- I think I just discovered the same pattern as **unliftio**? Certainly -- the signature is similar. I'm not sure if there is any benefit to -- restating this as a `withRunInIO` action; we're deliberately trying to -- constrain the types.-withContext ::- ((forall β. Program τ β -> IO β) -> IO α) ->- Program τ α+withContext+ :: ((forall β. Program τ β -> IO β) -> IO α)+ -> Program τ α withContext action = do context <- getContext let runThing = subProgram context
lib/Core/System.hs view
@@ -17,32 +17,32 @@ as there's no particular benefit to cherry-picking the various sub-modules. -}-module Core.System (- -- * Base libraries+module Core.System+ ( -- * Base libraries - -- |- -- Re-exports from foundational libraries supplied by the compiler runtime,- -- or from re-implementations of those areas.- module Core.System.Base,+ -- |+ -- Re-exports from foundational libraries supplied by the compiler runtime,+ -- or from re-implementations of those areas.+ module Core.System.Base - -- * External dependencies+ -- * External dependencies - -- |- -- Dependencies from libraries outside the traditional ecosystem of Haskell.- -- These are typically special cases or custom re-implementations of things- -- which are maintained either by ourselves or people we are in regular- -- contact with.- module Core.System.External,+ -- |+ -- Dependencies from libraries outside the traditional ecosystem of Haskell.+ -- These are typically special cases or custom re-implementations of things+ -- which are maintained either by ourselves or people we are in regular+ -- contact with.+ , module Core.System.External - -- * Pretty Printing+ -- * Pretty Printing - -- |- -- When using the Render typeclass from "Core.Text.Utilities" you are- -- presented with the @Doc a@ type for accumulating a \"document\" to be- -- pretty printed. There are a large family of combinators used when doing- -- this. For convenience they are exposed here.- module Core.System.Pretty,-) where+ -- |+ -- When using the Render typeclass from "Core.Text.Utilities" you are+ -- presented with the @Doc a@ type for accumulating a \"document\" to be+ -- pretty printed. There are a large family of combinators used when doing+ -- this. For convenience they are exposed here.+ , module Core.System.Pretty+ ) where import Core.System.Base import Core.System.External
lib/Core/System/Base.hs view
@@ -5,37 +5,36 @@ {- | Re-exports of Haskell base and GHC system libraries. -}-module Core.System.Base (- -- * Input/Output-- -- ** from Control.Monad.IO.Class+module Core.System.Base+ ( -- * Input/Output - -- | Re-exported from "Control.Monad.IO.Class" in __base__:- liftIO,- MonadIO,+ -- ** from Control.Monad.IO.Class - -- ** from System.IO+ -- | Re-exported from "Control.Monad.IO.Class" in __base__:+ liftIO+ , MonadIO - -- | Re-exported from "System.IO" in __base__:- Handle,- IOMode (..),- withFile,- stdin,- stdout,- stderr,- hFlush,- unsafePerformIO,+ -- ** from System.IO - -- * Exception handling+ -- | Re-exported from "System.IO" in __base__:+ , Handle+ , IOMode (..)+ , withFile+ , stdin+ , stdout+ , stderr+ , hFlush+ , unsafePerformIO - Exception (..),- SomeException,-) where+ -- * Exception handling+ , Exception (..)+ , SomeException+ ) where -import Control.Exception (- Exception (..),- SomeException,- )+import Control.Exception+ ( Exception (..)+ , SomeException+ ) import Control.Monad.IO.Class (MonadIO, liftIO) import System.IO (Handle, IOMode (..), hFlush, stderr, stdin, stdout, withFile) import System.IO.Unsafe (unsafePerformIO)
lib/Core/System/External.hs view
@@ -3,5 +3,6 @@ {- | Re-exports of dependencies from various external libraries. -}-module Core.System.External (+module Core.System.External+ ( ) where
lib/Core/System/Pretty.hs view
@@ -1,47 +1,47 @@ {-# OPTIONS_HADDOCK not-home #-} -- | Re-exports of combinators for use when building 'Core.Text.Utilities.Render' instances.-module Core.System.Pretty (- -- * Pretty Printing+module Core.System.Pretty+ ( -- * Pretty Printing - -- ** from Data.Text.Prettyprint.Doc+ -- ** from Data.Text.Prettyprint.Doc - -- | Re-exported from "Data.Text.Prettyprint.Doc" in __prettyprinter__ and "Data.Text.Prettyprint.Doc.Render.Terminal" in __prettyprinter-ansi-terminal__:- Doc,- Pretty (pretty),- dquote,- squote,- comma,- punctuate,- enclose,- lbracket,- rbracket,- (<+>),- lbrace,- rbrace,- lparen,- rparen,- emptyDoc,- sep,- hsep,- vsep,- fillCat,- fillSep,- flatAlt,- hcat,- vcat,- annotate,- unAnnotate,- line,- line',- softline,- softline',- hardline,- group,- hang,- indent,- nest,- concatWith,-) where+ -- | Re-exported from "Data.Text.Prettyprint.Doc" in __prettyprinter__ and "Data.Text.Prettyprint.Doc.Render.Terminal" in __prettyprinter-ansi-terminal__:+ Doc+ , Pretty (pretty)+ , dquote+ , squote+ , comma+ , punctuate+ , enclose+ , lbracket+ , rbracket+ , (<+>)+ , lbrace+ , rbrace+ , lparen+ , rparen+ , emptyDoc+ , sep+ , hsep+ , vsep+ , fillCat+ , fillSep+ , flatAlt+ , hcat+ , vcat+ , annotate+ , unAnnotate+ , line+ , line'+ , softline+ , softline'+ , hardline+ , group+ , hang+ , indent+ , nest+ , concatWith+ ) where import Prettyprinter