rio (empty) → 0.0.0.0
raw patch · 24 files changed
+1271/−0 lines, 24 filesdep +Win32dep +basedep +bytestring
Dependencies added: Win32, base, bytestring, containers, deepseq, directory, exceptions, filepath, hashable, microlens, mtl, text, time, typed-process, unix, unliftio, unordered-containers, vector
Files
- ChangeLog.md +4/−0
- LICENSE +20/−0
- README.md +98/−0
- rio.cabal +72/−0
- src/RIO.hs +4/−0
- src/RIO/ByteString.hs +5/−0
- src/RIO/ByteString/Lazy.hs +5/−0
- src/RIO/Directory.hs +6/−0
- src/RIO/FilePath.hs +5/−0
- src/RIO/HashMap.hs +5/−0
- src/RIO/HashSet.hs +5/−0
- src/RIO/List.hs +5/−0
- src/RIO/Logger.hs +286/−0
- src/RIO/Map.hs +5/−0
- src/RIO/Prelude.hs +280/−0
- src/RIO/Process.hs +424/−0
- src/RIO/Set.hs +5/−0
- src/RIO/Text.hs +7/−0
- src/RIO/Text/Lazy.hs +5/−0
- src/RIO/Time.hs +5/−0
- src/RIO/Vector.hs +5/−0
- src/RIO/Vector/Boxed.hs +5/−0
- src/RIO/Vector/Storable.hs +5/−0
- src/RIO/Vector/Unboxed.hs +5/−0
+ ChangeLog.md view
@@ -0,0 +1,4 @@+## 0.0++__NOTE__ All releases beginning with 0.0 are considered+experimental. Caveat emptor!
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2018 Michael Snoyman++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,98 @@+# The rio library++*A standard library for Haskell*++++__NOTE__ This code is currently in prerelease status, and has been+released as a tech preview. A number of us are actively working on+improving the project and getting it to a useful first release. For+more information, see the+[description of goals](https://github.com/snoyberg/codename-karka#readme)+and the+[issue tracker for discussions](https://github.com/snoyberg/codename-karka/issues). If+you're reading this file anywhere but Github, you should probably+[read the Github version instead](https://github.com/commercialhaskell/stack/tree/rio/subs/rio#readme),+which will be more up to date.++The goal of the `rio` library is to help you jump start your Haskell+coding. It is intended as a cross between:++* Collection of well designed, trusted libraries+* Useful `Prelude` replacement+* A set of best practices for writing production quality Haskell code++You're free to use any subset of functionality desired in your+project. This README will guide you through using `rio` to its fullest+extent.++## Standard library++While GHC ships with a `base` library, as well as another of other+common packages like `directory` and `transformers`, there are large+gaps in functionality provided by these libraries. This choice for a+more minimalistic `base` is by design, but it leads to some+unfortunate consequences:++* For a given task, it's often unclear which is the right library to+ use+* When writing libraries, there is often concern about adding+ dependencies to any libraries outside of `base`, due to creating a+ heavier dependency footprint+* By avoiding adding dependencies, many libraries end up+ reimplementing the same functionality, often with incompatible types+ and type classes, leading to difficulty using libraries together++This library attempts to define a standard library for Haskell. One+immediate response may be [XKCD #927](https://xkcd.com/927/):++++To counter that effect, this library takes a specific approach: __it+reuses existing, commonly used libraries__. Instead of defining an+incompatible `Map` type, for instance, we standardize on the commonly+used one from the `containers` library and reexport it from this+library.++This library attempts to define a set of libraries as "standard,"+meaning they are recommended for use, and should be encouraged as+dependencies for other libraries. It does this by depending on these+libraries itself, and reexporting their types and functions for easy+use.++Beyond the ecosystem effects we hope to achieve, this will hopefully+make the user story much easier. For a new user or team trying to get+started, there is an easy library to depend upon for a large+percentage of common functionality.++See the dependencies of this package to see the list of packages+considered standard. The primary interfaces of each of these packages+is exposed from this library via a `RIO.`-prefixed module reexporting+its interface.++## Prelude replacement++The `RIO` module works as a prelude replacement, providing more+functionality and types out of the box than the standard prelude (such+as common data types like `ByteString` and `Text`), as well as+removing common "gotchas", like partial functions and lazy I/O. The+guiding principle here is:++* If something is safe to use in general and has no expected naming+ conflicts, expose it from `RIO`+* If something should not always be used, or has naming conflicts,+ expose it from another module in the `RIO.` hierarchy.++## Best practices++__NOTE__ There is no need to follow any best practices listed here+when using `rio`. However, in some cases, `rio` will make design+decisions towards optimizing for these use cases. And for Haskellers+looking for a set of best practices to follow: you've come to the+right place!++For now, this is just a collection of links to existing best practices+documents. We'll expand in the future.++* https://www.fpcomplete.com/blog/2017/07/the-rio-monad+* https://www.fpcomplete.com/blog/2016/11/exceptions-best-practices-haskell
+ rio.cabal view
@@ -0,0 +1,72 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 6f5f94c9a9942eb49d41fe626d7dcef89c14fdbcb66c411c71b9ec99e6705971++name: rio+version: 0.0.0.0+synopsis: A standard library for Haskell+description: Work in progress library, see README at <https://github.com/commercialhaskell/stack/tree/rio/subs/rio#readme>+category: Control+author: Michael Snoyman+maintainer: michael@snoyman.com+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++library+ hs-source-dirs:+ src/+ build-depends:+ base <10+ , bytestring+ , containers+ , deepseq+ , directory+ , exceptions+ , filepath+ , hashable+ , microlens+ , mtl+ , text+ , time+ , typed-process >=0.2.1.0+ , unliftio >=0.2.4.0+ , unordered-containers+ , vector+ if os(windows)+ cpp-options: -DWINDOWS+ build-depends:+ Win32+ else+ build-depends:+ unix+ exposed-modules:+ RIO+ RIO.ByteString+ RIO.ByteString.Lazy+ RIO.Directory+ RIO.FilePath+ RIO.HashMap+ RIO.HashSet+ RIO.List+ RIO.Logger+ RIO.Map+ RIO.Process+ RIO.Set+ RIO.Text+ RIO.Text.Lazy+ RIO.Time+ RIO.Vector+ RIO.Vector.Boxed+ RIO.Vector.Storable+ RIO.Vector.Unboxed+ other-modules:+ RIO.Prelude+ default-language: Haskell2010
+ src/RIO.hs view
@@ -0,0 +1,4 @@+module RIO (module X) where++import RIO.Prelude as X+import RIO.Logger as X
+ src/RIO/ByteString.hs view
@@ -0,0 +1,5 @@+module RIO.ByteString+ ( module X+ ) where++import Data.ByteString as X
+ src/RIO/ByteString/Lazy.hs view
@@ -0,0 +1,5 @@+module RIO.ByteString.Lazy+ ( module X+ ) where++import Data.ByteString.Lazy as X
+ src/RIO/Directory.hs view
@@ -0,0 +1,6 @@+-- FIXME lift/unlift functions+module RIO.Directory+ ( module X+ ) where++import System.Directory as X
+ src/RIO/FilePath.hs view
@@ -0,0 +1,5 @@+module RIO.FilePath+ ( module X+ ) where++import System.FilePath as X
+ src/RIO/HashMap.hs view
@@ -0,0 +1,5 @@+module RIO.HashMap+ ( module X+ ) where++import Data.HashMap.Strict as X
+ src/RIO/HashSet.hs view
@@ -0,0 +1,5 @@+module RIO.HashSet+ ( module X+ ) where++import Data.HashSet as X
+ src/RIO/List.hs view
@@ -0,0 +1,5 @@+module RIO.List+ ( module X+ ) where++import Data.List as X
+ src/RIO/Logger.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE NoImplicitPrelude #-}+module RIO.Logger+ ( LogLevel (..)+ , LogSource+ , LogStr+ , LogFunc+ , HasLogFunc (..)+ , logGeneric+ , logDebug+ , logInfo+ , logWarn+ , logError+ , logOther+ , logSticky+ , logStickyDone+ , runNoLogging+ , NoLogging (..)+ , withStickyLogger+ , LogOptions (..)+ ) where++import RIO.Prelude+import Data.Text (Text)+import qualified Data.Text as T+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)+import Lens.Micro (to)+import GHC.Stack (HasCallStack, CallStack, SrcLoc (..), getCallStack)+import Data.Time+import qualified Data.Text.IO as TIO+import Data.ByteString.Builder (toLazyByteString, char7)+import GHC.IO.Handle.Internals (wantWritableHandle)+import GHC.IO.Encoding.Types (textEncodingName)+import GHC.IO.Handle.Types (Handle__ (..))+import qualified Data.ByteString as B++data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther !Text+ deriving (Eq, Show, Read, Ord)++type LogSource = Text+type LogStr = DisplayBuilder+class HasLogFunc env where+ logFuncL :: SimpleGetter env LogFunc++type LogFunc = CallStack -> LogSource -> LogLevel -> LogStr -> IO ()++logGeneric+ :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)+ => LogSource+ -> LogLevel+ -> LogStr+ -> m ()+logGeneric src level str = do+ logFunc <- view logFuncL+ liftIO $ logFunc ?callStack src level str++logDebug+ :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)+ => LogStr+ -> m ()+logDebug = logGeneric "" LevelDebug++logInfo+ :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)+ => LogStr+ -> m ()+logInfo = logGeneric "" LevelInfo++logWarn+ :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)+ => LogStr+ -> m ()+logWarn = logGeneric "" LevelWarn++logError+ :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)+ => LogStr+ -> m ()+logError = logGeneric "" LevelError++logOther+ :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)+ => Text -- ^ level+ -> LogStr+ -> m ()+logOther = logGeneric "" . LevelOther++runNoLogging :: MonadIO m => ReaderT NoLogging m a -> m a+runNoLogging = flip runReaderT NoLogging++data NoLogging = NoLogging+instance HasLogFunc NoLogging where+ logFuncL = to (\_ _ _ _ _ -> return ())++-- | Write a "sticky" line to the terminal. Any subsequent lines will+-- overwrite this one, and that same line will be repeated below+-- again. In other words, the line sticks at the bottom of the output+-- forever. Running this function again will replace the sticky line+-- with a new sticky line. When you want to get rid of the sticky+-- line, run 'logStickyDone'.+--+logSticky :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => LogStr -> m ()+logSticky = logOther "sticky"++-- | This will print out the given message with a newline and disable+-- any further stickiness of the line until a new call to 'logSticky'+-- happens.+--+-- It might be better at some point to have a 'runSticky' function+-- that encompasses the logSticky->logStickyDone pairing.+logStickyDone :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => LogStr -> m ()+logStickyDone = logOther "sticky-done"++canUseUtf8 :: MonadIO m => Handle -> m Bool+canUseUtf8 h = liftIO $ wantWritableHandle "canUseUtf8" h $ \h_ -> do+ -- TODO also handle haOutputNL for CRLF+ return $ (textEncodingName <$> haCodec h_) == Just "UTF-8"++withStickyLogger :: MonadIO m => LogOptions -> (LogFunc -> m a) -> m a+withStickyLogger options inner = do+ useUtf8 <- canUseUtf8 stderr+ let printer =+ if useUtf8 && logUseUnicode options+ then \db -> do+ hPutBuilder stderr $ getUtf8Builder db+ hFlush stderr+ else \db -> do+ let lbs = toLazyByteString $ getUtf8Builder db+ bs = toStrictBytes lbs+ text <-+ case decodeUtf8' bs of+ Left e -> error $ "mkStickyLogger: invalid UTF8 sequence: " ++ show (e, bs)+ Right text -> return text+ let text'+ | logUseUnicode options = text+ | otherwise = T.map replaceUnicode text+ TIO.hPutStr stderr text'+ hFlush stderr+ if logTerminal options+ then withSticky $ \var ->+ inner $ stickyImpl var options (simpleLogFunc options printer)+ else+ inner $ \cs src level str ->+ simpleLogFunc options printer cs src (noSticky level) str++-- | Replace Unicode characters with non-Unicode equivalents+replaceUnicode :: Char -> Char+replaceUnicode '\x2018' = '`'+replaceUnicode '\x2019' = '\''+replaceUnicode c = c++noSticky :: LogLevel -> LogLevel+noSticky (LevelOther "sticky-done") = LevelInfo+noSticky (LevelOther "sticky") = LevelInfo+noSticky level = level++data LogOptions = LogOptions+ { logMinLevel :: !LogLevel+ , logVerboseFormat :: !Bool+ , logTerminal :: !Bool+ , logUseTime :: !Bool+ , logUseColor :: !Bool+ , logUseUnicode :: !Bool+ }++simpleLogFunc :: LogOptions -> (LogStr -> IO ()) -> LogFunc+simpleLogFunc lo printer cs _src level msg =+ when (level >= logMinLevel lo) $ do+ timestamp <- getTimestamp+ printer $+ timestamp <>+ getLevel <>+ " " <>+ ansi reset <>+ msg <>+ getLoc <>+ ansi reset <>+ "\n"+ where+ reset = "\ESC[0m"+ setBlack = "\ESC[90m"+ setGreen = "\ESC[32m"+ setBlue = "\ESC[34m"+ setYellow = "\ESC[33m"+ setRed = "\ESC[31m"+ setMagenta = "\ESC[35m"++ ansi :: DisplayBuilder -> DisplayBuilder+ ansi xs | logUseColor lo = xs+ | otherwise = mempty++ getTimestamp :: IO DisplayBuilder+ getTimestamp+ | logVerboseFormat lo && logUseTime lo =+ do now <- getZonedTime+ return $ ansi setBlack <> fromString (formatTime' now) <> ": "+ | otherwise = return mempty+ where+ formatTime' =+ take timestampLength . formatTime defaultTimeLocale "%F %T.%q"++ getLevel :: DisplayBuilder+ getLevel+ | logVerboseFormat lo =+ case level of+ LevelDebug -> ansi setGreen <> "[debug]"+ LevelInfo -> ansi setBlue <> "[info]"+ LevelWarn -> ansi setYellow <> "[warn]"+ LevelError -> ansi setRed <> "[error]"+ LevelOther name ->+ ansi setMagenta <>+ "[" <>+ display name <>+ "] "+ | otherwise = mempty++ getLoc :: DisplayBuilder+ getLoc+ | logVerboseFormat lo = ansi setBlack <> "\n@(" <> fileLocStr <> ")"+ | otherwise = mempty++ fileLocStr :: DisplayBuilder+ fileLocStr =+ case reverse $ getCallStack cs of+ [] -> "<no call stack found>"+ (_desc, loc):_ ->+ let file = srcLocFile loc+ in fromString file <>+ ":" <>+ displayShow (srcLocStartLine loc) <>+ ":" <>+ displayShow (srcLocStartCol loc)++-- | The length of a timestamp in the format "YYYY-MM-DD hh:mm:ss.μμμμμμ".+-- This definition is top-level in order to avoid multiple reevaluation at runtime.+timestampLength :: Int+timestampLength =+ length (formatTime defaultTimeLocale "%F %T.000000" (UTCTime (ModifiedJulianDay 0) 0))++stickyImpl+ :: MVar ByteString -> LogOptions -> LogFunc+ -> (CallStack -> LogSource -> LogLevel -> LogStr -> IO ())+stickyImpl ref lo logFunc loc src level msgOrig = modifyMVar_ ref $ \sticky -> do+ let backSpaceChar = '\8'+ repeating = mconcat . replicate (B.length sticky) . char7+ clear = hPutBuilder stderr+ (repeating backSpaceChar <>+ repeating ' ' <>+ repeating backSpaceChar)++ case level of+ LevelOther "sticky-done" -> do+ clear+ logFunc loc src LevelInfo msgOrig+ hFlush stderr+ return mempty+ LevelOther "sticky" -> do+ clear+ let bs = toStrictBytes $ toLazyByteString $ getUtf8Builder msgOrig+ B.hPut stderr bs+ hFlush stderr+ return bs+ _+ | level >= logMinLevel lo -> do+ clear+ logFunc loc src level msgOrig+ unless (B.null sticky) $ do+ B.hPut stderr sticky+ hFlush stderr+ return sticky+ | otherwise -> return sticky++-- | With a sticky state, do the thing.+withSticky :: (MonadIO m) => (MVar ByteString -> m b) -> m b+withSticky inner = do+ state <- newMVar mempty+ originalMode <- liftIO (hGetBuffering stdout)+ liftIO (hSetBuffering stdout NoBuffering)+ a <- inner state+ state' <- takeMVar state+ liftIO $ do+ unless (B.null state') (B.putStr "\n")+ hSetBuffering stdout originalMode+ return a
+ src/RIO/Map.hs view
@@ -0,0 +1,5 @@+module RIO.Map+ ( module X+ ) where++import Data.Map.Strict as X
+ src/RIO/Prelude.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}+module RIO.Prelude+ ( mapLeft+ , withLazyFile+ , fromFirst+ , mapMaybeA+ , mapMaybeM+ , forMaybeA+ , forMaybeM+ , stripCR+ , RIO (..)+ , runRIO+ , liftRIO+ , tshow+ , readFileBinary+ , writeFileBinary+ , ReadFileUtf8Exception (..)+ , readFileUtf8+ , writeFileUtf8+ , LByteString+ , toStrictBytes+ , fromStrictBytes+ , decodeUtf8Lenient+ , LText+ , view+ , UVector+ , SVector+ , GVector+ , module X+ , DisplayBuilder (..)+ , Display (..)+ , displayShow+ , displayBuilderToText+ , displayBytesUtf8+ , writeFileDisplayBuilder+ , hPutBuilder+ , sappend+ ) where++import Control.Applicative as X (Alternative, Applicative (..),+ liftA, liftA2, liftA3, many,+ optional, some, (<|>))+import Control.Arrow as X (first, second, (&&&), (***))+import Control.DeepSeq as X (NFData (..), force, ($!!))+import Control.Monad as X (Monad (..), MonadPlus (..), filterM,+ foldM, foldM_, forever, guard, join,+ liftM, liftM2, replicateM_, unless,+ when, zipWithM, zipWithM_, (<$!>),+ (<=<), (=<<), (>=>))+import Control.Monad.Catch as X (MonadThrow (..))+import Control.Monad.Reader as X (MonadReader, MonadTrans (..),+ ReaderT (..), ask, asks, local)+import Data.Bool as X (Bool (..), not, otherwise, (&&),+ (||))+import Data.ByteString as X (ByteString)+import Data.ByteString.Builder as X (Builder)+import Data.ByteString.Short as X (ShortByteString, toShort, fromShort)+import Data.Char as X (Char)+import Data.Data as X (Data (..))+import Data.Either as X (Either (..), either, isLeft,+ isRight, lefts, partitionEithers,+ rights)+import Data.Eq as X (Eq (..))+import Data.Foldable as X (Foldable, all, and, any, asum,+ concat, concatMap, elem, fold,+ foldMap, foldl', foldr, forM_, for_,+ length, mapM_, msum, notElem, null,+ or, product, sequenceA_, sequence_,+ sum, toList, traverse_)+import Data.Function as X (const, fix, flip, id, on, ($), (&),+ (.))+import Data.Functor as X (Functor (..), void, ($>), (<$),+ (<$>))+import Data.Hashable as X (Hashable)+import Data.HashMap.Strict as X (HashMap)+import Data.HashSet as X (HashSet)+import Data.Int as X+import Data.IntMap.Strict as X (IntMap)+import Data.IntSet as X (IntSet)+import Data.List as X (break, drop, dropWhile, filter,+ lines, lookup, map, replicate,+ reverse, span, take, takeWhile,+ unlines, unwords, words, zip, (++))+import Data.Map.Strict as X (Map)+import Data.Maybe as X (Maybe (..), catMaybes, fromMaybe,+ isJust, isNothing, listToMaybe,+ mapMaybe, maybe, maybeToList)+import Data.Monoid as X (All (..), Any (..), Endo (..),+ First (..), Last (..), Monoid (..),+ Product (..), Sum (..), (<>))+import Data.Ord as X (Ord (..), Ordering (..), comparing)+import Data.Semigroup as X (Semigroup)+import Data.Set as X (Set)+import Data.String as X (IsString (..))+import Data.Text as X (Text)+import Data.Text.Encoding as X (encodeUtf8, decodeUtf8', decodeUtf8With, encodeUtf8Builder)+import Data.Text.Encoding.Error as X (lenientDecode, UnicodeException (..))+import Data.Traversable as X (Traversable (..), for, forM)+import Data.Vector as X (Vector)+import Data.Void as X (Void, absurd)+import Data.Word as X+import Foreign.Storable as X (Storable)+import GHC.Generics as X (Generic)+import GHC.Stack as X (HasCallStack)+import Lens.Micro as X (ASetter, ASetter', sets, over, set, SimpleGetter, Getting, (^.), to, Lens, Lens', lens)+import Prelude as X (Bounded (..), Double, Enum,+ FilePath, Float, Floating (..),+ Fractional (..), IO, Integer,+ Integral (..), Num (..), Rational,+ Real (..), RealFloat (..),+ RealFrac (..), Show, String,+ asTypeOf, curry, error, even,+ fromIntegral, fst, gcd, lcm, odd,+ realToFrac, seq, show, snd,+ subtract, uncurry, undefined, ($!),+ (^), (^^))+import System.Exit as X (ExitCode (..))+import Text.Read as X (Read, readMaybe)+import UnliftIO as X++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++import qualified Data.Vector.Unboxed as UVector+import qualified Data.Vector.Storable as SVector+import qualified Data.Vector.Generic as GVector++import qualified Data.ByteString.Builder as BB+import qualified Data.Semigroup++import Control.Applicative (Const (..))+import Lens.Micro.Internal ((#.))++mapLeft :: (a1 -> a2) -> Either a1 b -> Either a2 b+mapLeft f (Left a1) = Left (f a1)+mapLeft _ (Right b) = Right b++fromFirst :: a -> First a -> a+fromFirst x = fromMaybe x . getFirst++-- | Applicative 'mapMaybe'.+mapMaybeA :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b]+mapMaybeA f = fmap catMaybes . traverse f++-- | @'forMaybeA' '==' 'flip' 'mapMaybeA'@+forMaybeA :: Applicative f => [a] -> (a -> f (Maybe b)) -> f [b]+forMaybeA = flip mapMaybeA++-- | Monadic 'mapMaybe'.+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM f = liftM catMaybes . mapM f++-- | @'forMaybeM' '==' 'flip' 'mapMaybeM'@+forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b]+forMaybeM = flip mapMaybeM++-- | Strip trailing carriage return from Text+stripCR :: T.Text -> T.Text+stripCR t = fromMaybe t (T.stripSuffix "\r" t)++-- | Lazily get the contents of a file. Unlike 'BL.readFile', this+-- ensures that if an exception is thrown, the file handle is closed+-- immediately.+withLazyFile :: MonadUnliftIO m => FilePath -> (BL.ByteString -> m a) -> m a+withLazyFile fp inner = withBinaryFile fp ReadMode $ inner <=< liftIO . BL.hGetContents++-- | The Reader+IO monad. This is different from a 'ReaderT' because:+--+-- * It's not a transformer, it hardcodes IO for simpler usage and+-- error messages.+--+-- * Instances of typeclasses like 'MonadLogger' are implemented using+-- classes defined on the environment, instead of using an+-- underlying monad.+newtype RIO env a = RIO { unRIO :: ReaderT env IO a }+ deriving (Functor,Applicative,Monad,MonadIO,MonadReader env,MonadThrow)++runRIO :: MonadIO m => env -> RIO env a -> m a+runRIO env (RIO (ReaderT f)) = liftIO (f env)++liftRIO :: (MonadIO m, MonadReader env m) => RIO env a -> m a+liftRIO rio = do+ env <- ask+ runRIO env rio++instance MonadUnliftIO (RIO env) where+ askUnliftIO = RIO $ ReaderT $ \r ->+ withUnliftIO $ \u ->+ return (UnliftIO (unliftIO u . flip runReaderT r . unRIO))++tshow :: Show a => a -> Text+tshow = T.pack . show++-- | Same as 'B.readFile', but generalized to 'MonadIO'+readFileBinary :: MonadIO m => FilePath -> m ByteString+readFileBinary = liftIO . B.readFile++-- | Same as 'B.writeFile', but generalized to 'MonadIO'+writeFileBinary :: MonadIO m => FilePath -> ByteString -> m ()+writeFileBinary fp = liftIO . B.writeFile fp++-- | Read a file in UTF8 encoding, throwing an exception on invalid character+-- encoding.+readFileUtf8 :: MonadIO m => FilePath -> m Text+readFileUtf8 fp = do+ bs <- readFileBinary fp+ case decodeUtf8' bs of+ Left e -> throwIO $ ReadFileUtf8Exception fp e+ Right text -> return text++data ReadFileUtf8Exception = ReadFileUtf8Exception !FilePath !UnicodeException+ deriving (Show, Typeable)+instance Exception ReadFileUtf8Exception++-- | Write a file in UTF8 encoding+writeFileUtf8 :: MonadIO m => FilePath -> Text -> m ()+writeFileUtf8 fp = writeFileBinary fp . encodeUtf8++type LByteString = BL.ByteString++toStrictBytes :: LByteString -> ByteString+toStrictBytes = BL.toStrict++fromStrictBytes :: ByteString -> LByteString+fromStrictBytes = BL.fromStrict++view :: MonadReader s m => Getting a s a -> m a+view l = asks (getConst #. l Const)++type UVector = UVector.Vector+type SVector = SVector.Vector+type GVector = GVector.Vector++decodeUtf8Lenient :: ByteString -> Text+decodeUtf8Lenient = decodeUtf8With lenientDecode++type LText = TL.Text++newtype DisplayBuilder = DisplayBuilder { getUtf8Builder :: Builder }+ deriving (Semigroup, Monoid)++instance IsString DisplayBuilder where+ fromString = DisplayBuilder . BB.stringUtf8++class Display a where+ display :: a -> DisplayBuilder+instance Display Text where+ display = DisplayBuilder . encodeUtf8Builder+instance Display LText where+ display = foldMap display . TL.toChunks+instance Display Int where+ display = DisplayBuilder . BB.intDec++displayShow :: Show a => a -> DisplayBuilder+displayShow = fromString . show++displayBytesUtf8 :: ByteString -> DisplayBuilder+displayBytesUtf8 = DisplayBuilder . BB.byteString++displayBuilderToText :: DisplayBuilder -> Text+displayBuilderToText =+ decodeUtf8With lenientDecode . BL.toStrict . BB.toLazyByteString . getUtf8Builder++sappend :: Semigroup s => s -> s -> s+sappend = (Data.Semigroup.<>)++writeFileDisplayBuilder :: MonadIO m => FilePath -> DisplayBuilder -> m ()+writeFileDisplayBuilder fp (DisplayBuilder builder) =+ liftIO $ withBinaryFile fp WriteMode $ \h -> hPutBuilder h builder++hPutBuilder :: MonadIO m => Handle -> Builder -> m ()+hPutBuilder h = liftIO . BB.hPutBuilder h+{-# INLINE hPutBuilder #-}
+ src/RIO/Process.hs view
@@ -0,0 +1,424 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Reading from external processes.++module RIO.Process+ (withProcess+ ,withProcess_+ ,EnvOverride(..)+ ,unEnvOverride+ ,mkEnvOverride+ ,modifyEnvOverride+ ,envHelper+ ,doesExecutableExist+ ,findExecutable+ ,getEnvOverride+ ,envSearchPath+ ,preProcess+ ,readProcessNull+ ,ReadProcessException (..)+ ,augmentPath+ ,augmentPathMap+ ,resetExeCache+ ,HasEnvOverride (..)+ ,workingDirL+ ,withProc+ ,withEnvOverride+ ,withModifyEnvOverride+ ,withWorkingDir+ ,runEnvNoLogging+ ,withProcessTimeLog+ ,showProcessArgDebug+ ,exec+ ,execSpawn+ ,execObserve+ ,module System.Process.Typed+ )+ where++import RIO.Prelude+import RIO.Logger+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import Data.Text.Encoding.Error (lenientDecode)+import Lens.Micro (set, to)+import qualified System.Directory as D+import System.Environment (getEnvironment)+import System.Exit (exitWith)+import qualified System.FilePath as FP+import qualified System.Process.Typed as P+import System.Process.Typed hiding (withProcess, withProcess_)++#ifndef WINDOWS+import System.Directory (setCurrentDirectory)+import System.Posix.Process (executeFile)+#endif++class HasLogFunc env => HasEnvOverride env where+ envOverrideL :: Lens' env EnvOverride++data EnvVarFormat = EVFWindows | EVFNotWindows++currentEnvVarFormat :: EnvVarFormat+currentEnvVarFormat =+#if WINDOWS+ EVFWindows+#else+ EVFNotWindows+#endif++-- | Override the environment received by a child process.+data EnvOverride = EnvOverride+ { eoTextMap :: Map Text Text -- ^ Environment variables as map+ , eoStringList :: [(String, String)] -- ^ Environment variables as association list+ , eoPath :: [FilePath] -- ^ List of directories searched for executables (@PATH@)+ , eoExeCache :: IORef (Map FilePath (Either ReadProcessException FilePath))+ , eoExeExtensions :: [String] -- ^ @[""]@ on non-Windows systems, @["", ".exe", ".bat"]@ on Windows+ , eoWorkingDir :: !(Maybe FilePath)+ }++workingDirL :: HasEnvOverride env => Lens' env (Maybe FilePath)+workingDirL = envOverrideL.lens eoWorkingDir (\x y -> x { eoWorkingDir = y })++-- | Get the environment variables from an 'EnvOverride'.+unEnvOverride :: EnvOverride -> Map Text Text+unEnvOverride = eoTextMap++-- | Get the list of directories searched (@PATH@).+envSearchPath :: EnvOverride -> [FilePath]+envSearchPath = eoPath++-- | Modify the environment variables of an 'EnvOverride'.+modifyEnvOverride :: MonadIO m+ => EnvOverride+ -> (Map Text Text -> Map Text Text)+ -> m EnvOverride+modifyEnvOverride eo f = mkEnvOverride (f $ eoTextMap eo)++-- | Create a new 'EnvOverride'.+mkEnvOverride :: MonadIO m+ => Map Text Text+ -> m EnvOverride+mkEnvOverride tm' = do+ ref <- liftIO $ newIORef Map.empty+ return EnvOverride+ { eoTextMap = tm+ , eoStringList = map (T.unpack *** T.unpack) $ Map.toList tm+ , eoPath =+ (if isWindows then (".":) else id)+ (maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm))+ , eoExeCache = ref+ , eoExeExtensions =+ if isWindows+ then let pathext = fromMaybe+ ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC"+ (Map.lookup "PATHEXT" tm)+ in map T.unpack $ "" : T.splitOn ";" pathext+ else [""]+ , eoWorkingDir = Nothing+ }+ where+ -- Fix case insensitivity of the PATH environment variable on Windows.+ tm+ | isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm'+ | otherwise = tm'++ -- Don't use CPP so that the Windows code path is at least type checked+ -- regularly+ isWindows =+ case currentEnvVarFormat of+ EVFWindows -> True+ EVFNotWindows -> False++-- | Helper conversion function.+envHelper :: EnvOverride -> [(String, String)]+envHelper = eoStringList++-- | Read from the process, ignoring any output.+--+-- Throws a 'ReadProcessException' exception if the process fails.+readProcessNull :: HasEnvOverride env -- FIXME remove+ => String -- ^ Command+ -> [String] -- ^ Command line arguments+ -> RIO env ()+readProcessNull name args =+ -- We want the output to appear in any exceptions, so we capture and drop it+ void $ withProc name args readProcessStdout_++-- | An exception while trying to read from process.+data ReadProcessException+ = NoPathFound+ | ExecutableNotFound String [FilePath]+ | ExecutableNotFoundAt FilePath+ deriving Typeable+instance Show ReadProcessException where+ show NoPathFound = "PATH not found in EnvOverride"+ show (ExecutableNotFound name path) = concat+ [ "Executable named "+ , name+ , " not found on path: "+ , show path+ ]+ show (ExecutableNotFoundAt name) =+ "Did not find executable at specified path: " ++ name+instance Exception ReadProcessException++-- | Provide a 'ProcessConfig' based on the 'EnvOverride' in+-- scope. Deals with resolving the full path, setting the child+-- process's environment variables, setting the working directory, and+-- wrapping the call with 'withProcessTimeLog' for debugging output.+withProc+ :: HasEnvOverride env+ => FilePath -- ^ command to run+ -> [String] -- ^ command line arguments+ -> (ProcessConfig () () () -> RIO env a)+ -> RIO env a+withProc name0 args inner = do+ menv <- view envOverrideL+ name <- preProcess name0++ withProcessTimeLog (eoWorkingDir menv) name args+ $ inner+ $ setEnv (envHelper menv)+ $ maybe id setWorkingDir (eoWorkingDir menv)+ $ proc name args++-- | Apply the given function to the modified environment+-- variables. For more details, see 'withEnvOverride'.+withModifyEnvOverride :: HasEnvOverride env => (Map Text Text -> Map Text Text) -> RIO env a -> RIO env a+withModifyEnvOverride f inner = do+ menv <- view envOverrideL+ menv' <- modifyEnvOverride menv f+ withEnvOverride menv' inner++-- | Set a new 'EnvOverride' in the child reader. Note that this will+-- keep the working directory set in the parent with 'withWorkingDir'.+withEnvOverride :: HasEnvOverride env => EnvOverride -> RIO env a -> RIO env a+withEnvOverride newEnv = local $ \r ->+ let newEnv' = newEnv { eoWorkingDir = eoWorkingDir $ view envOverrideL r }+ in set envOverrideL newEnv' r++-- | Set the working directory to be used by child processes.+withWorkingDir :: HasEnvOverride env => FilePath -> RIO env a -> RIO env a+withWorkingDir = local . set workingDirL . Just++-- | Perform pre-call-process tasks. Ensure the working directory exists and find the+-- executable path.+--+-- Throws a 'ReadProcessException' if unsuccessful.+preProcess+ :: HasEnvOverride env+ => String -- ^ Command name+ -> RIO env FilePath+preProcess name = do+ menv <- view envOverrideL+ let wd = eoWorkingDir menv+ name' <- liftIO $ join $ findExecutable menv name+ liftIO $ maybe (return ()) (D.createDirectoryIfMissing True) wd+ return name'++-- | Check if the given executable exists on the given PATH.+doesExecutableExist :: (MonadIO m)+ => EnvOverride -- ^ How to override environment+ -> String -- ^ Name of executable+ -> m Bool+doesExecutableExist menv name = liftM isJust $ findExecutable menv name++-- | Find the complete path for the executable.+--+-- Throws a 'ReadProcessException' if unsuccessful.+findExecutable :: (MonadIO m, MonadThrow n)+ => EnvOverride -- ^ How to override environment+ -> String -- ^ Name of executable+ -> m (n FilePath) -- ^ Full path to that executable on success+findExecutable eo name0 | any FP.isPathSeparator name0 = do+ let names0 = map (name0 ++) (eoExeExtensions eo)+ testNames [] = return $ throwM $ ExecutableNotFoundAt name0+ testNames (name:names) = do+ exists <- liftIO $ D.doesFileExist name+ if exists+ then do+ path <- liftIO $ D.canonicalizePath name+ return $ return path+ else testNames names+ testNames names0+findExecutable eo name = liftIO $ do+ m <- readIORef $ eoExeCache eo+ epath <- case Map.lookup name m of+ Just epath -> return epath+ Nothing -> do+ let loop [] = return $ Left $ ExecutableNotFound name (eoPath eo)+ loop (dir:dirs) = do+ let fp0 = dir FP.</> name+ fps0 = map (fp0 ++) (eoExeExtensions eo)+ testFPs [] = loop dirs+ testFPs (fp:fps) = do+ exists <- D.doesFileExist fp+ existsExec <- if exists then liftM D.executable $ D.getPermissions fp else return False+ if existsExec+ then do+ fp' <- D.makeAbsolute fp+ return $ return fp'+ else testFPs fps+ testFPs fps0+ epath <- loop $ eoPath eo+ () <- atomicModifyIORef (eoExeCache eo) $ \m' ->+ (Map.insert name epath m', ())+ return epath+ return $ either throwM return epath++-- | Reset the executable cache.+resetExeCache :: MonadIO m => EnvOverride -> m ()+resetExeCache eo = liftIO (atomicModifyIORef (eoExeCache eo) (const mempty))++-- | Load up an 'EnvOverride' from the standard environment.+getEnvOverride :: MonadIO m => m EnvOverride+getEnvOverride =+ liftIO $+ getEnvironment >>=+ mkEnvOverride+ . Map.fromList . map (T.pack *** T.pack)++newtype InvalidPathException = PathsInvalidInPath [FilePath]+ deriving Typeable++instance Exception InvalidPathException+instance Show InvalidPathException where+ show (PathsInvalidInPath paths) = unlines $+ [ "Would need to add some paths to the PATH environment variable \+ \to continue, but they would be invalid because they contain a "+ ++ show FP.searchPathSeparator ++ "."+ , "Please fix the following paths and try again:"+ ] ++ paths++-- | Augment the PATH environment variable with the given extra paths.+augmentPath :: MonadThrow m => [FilePath] -> Maybe Text -> m Text+augmentPath dirs mpath =+ do let illegal = filter (FP.searchPathSeparator `elem`) dirs+ unless (null illegal) (throwM $ PathsInvalidInPath illegal)+ return $ T.intercalate (T.singleton FP.searchPathSeparator)+ $ map (T.pack . FP.dropTrailingPathSeparator) dirs+ ++ maybeToList mpath++-- | Apply 'augmentPath' on the PATH value in the given Map.+augmentPathMap :: MonadThrow m => [FilePath] -> Map Text Text -> m (Map Text Text)+augmentPathMap dirs origEnv =+ do path <- augmentPath dirs mpath+ return $ Map.insert "PATH" path origEnv+ where+ mpath = Map.lookup "PATH" origEnv++runEnvNoLogging :: RIO EnvNoLogging a -> IO a+runEnvNoLogging inner = do+ menv <- getEnvOverride+ runRIO (EnvNoLogging menv) inner++newtype EnvNoLogging = EnvNoLogging EnvOverride+instance HasLogFunc EnvNoLogging where+ logFuncL = to (\_ _ _ _ _ -> return ())+instance HasEnvOverride EnvNoLogging where+ envOverrideL = lens (\(EnvNoLogging x) -> x) (const EnvNoLogging)++-- | Log running a process with its arguments, for debugging (-v).+--+-- This logs one message before running the process and one message after.+withProcessTimeLog :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Maybe FilePath -> String -> [String] -> m a -> m a+withProcessTimeLog mdir name args proc' = do+ let cmdText =+ T.intercalate+ " "+ (T.pack name : map showProcessArgDebug args)+ dirMsg =+ case mdir of+ Nothing -> ""+ Just dir -> " within " <> T.pack dir+ logDebug ("Run process" <> display dirMsg <> ": " <> display cmdText)+ start <- getMonotonicTime+ x <- proc'+ end <- getMonotonicTime+ let diff = end - start+ -- useAnsi <- asks getAnsiTerminal FIXME+ let useAnsi = True+ logDebug+ ("Process finished in " <>+ (if useAnsi then "\ESC[92m" else "") <> -- green+ timeSpecMilliSecondText diff <>+ (if useAnsi then "\ESC[0m" else "") <> -- reset+ ": " <> display cmdText)+ return x++timeSpecMilliSecondText :: Double -> DisplayBuilder+timeSpecMilliSecondText d = display (round (d * 1000) :: Int) <> "ms"++-- | Show a process arg including speechmarks when necessary. Just for+-- debugging purposes, not functionally important.+showProcessArgDebug :: String -> Text+showProcessArgDebug x+ | any special x || null x = T.pack (show x)+ | otherwise = T.pack x+ where special '"' = True+ special ' ' = True+ special _ = False++-- | Execute a process within the Stack configured environment.+--+-- Execution will not return, because either:+--+-- 1) On non-windows, execution is taken over by execv of the+-- sub-process. This allows signals to be propagated (#527)+--+-- 2) On windows, an 'ExitCode' exception will be thrown.+exec :: HasEnvOverride env => String -> [String] -> RIO env b+#ifdef WINDOWS+exec = execSpawn+#else+exec cmd0 args = do+ menv <- view envOverrideL+ cmd <- preProcess cmd0+ withProcessTimeLog Nothing cmd args $ liftIO $ do+ for_ (eoWorkingDir menv) setCurrentDirectory+ executeFile cmd True args $ Just $ envHelper menv+#endif++-- | Like 'exec', but does not use 'execv' on non-windows. This way, there+-- is a sub-process, which is helpful in some cases (#1306)+--+-- This function only exits by throwing 'ExitCode'.+execSpawn :: HasEnvOverride env => String -> [String] -> RIO env a+execSpawn cmd args = withProc cmd args (runProcess . setStdin inherit) >>= liftIO . exitWith++execObserve :: HasEnvOverride env => String -> [String] -> RIO env String+execObserve cmd0 args =+ withProc cmd0 args $ \pc -> do+ (out, _err) <- readProcess_ pc+ return+ $ TL.unpack+ $ TL.filter (/= '\r')+ $ TL.concat+ $ take 1+ $ TL.lines+ $ TLE.decodeUtf8With lenientDecode out++-- | Same as 'P.withProcess', but generalized to 'MonadUnliftIO'.+withProcess+ :: MonadUnliftIO m+ => ProcessConfig stdin stdout stderr+ -> (Process stdin stdout stderr -> m a)+ -> m a+withProcess pc f = withRunInIO $ \run -> P.withProcess pc (run . f)++-- | Same as 'P.withProcess_', but generalized to 'MonadUnliftIO'.+withProcess_+ :: MonadUnliftIO m+ => ProcessConfig stdin stdout stderr+ -> (Process stdin stdout stderr -> m a)+ -> m a+withProcess_ pc f = withRunInIO $ \run -> P.withProcess_ pc (run . f)
+ src/RIO/Set.hs view
@@ -0,0 +1,5 @@+module RIO.Set+ ( module X+ ) where++import Data.Set as X
+ src/RIO/Text.hs view
@@ -0,0 +1,7 @@+module RIO.Text+ ( module X+ ) where++import Data.Text as X -- FIXME hide partials+import Data.Text.Encoding as X (encodeUtf8, decodeUtf8With, decodeUtf8')+import Data.Text.Encoding.Error as X (lenientDecode)
+ src/RIO/Text/Lazy.hs view
@@ -0,0 +1,5 @@+module RIO.Text.Lazy+ ( module X+ ) where++import Data.Text.Lazy as X
+ src/RIO/Time.hs view
@@ -0,0 +1,5 @@+module RIO.Time+ ( module X+ ) where++import Data.Time as X
+ src/RIO/Vector.hs view
@@ -0,0 +1,5 @@+module RIO.Vector+ ( module X+ ) where++import Data.Vector.Generic as X
+ src/RIO/Vector/Boxed.hs view
@@ -0,0 +1,5 @@+module RIO.Vector.Boxed+ ( module X+ ) where++import Data.Vector as X
+ src/RIO/Vector/Storable.hs view
@@ -0,0 +1,5 @@+module RIO.Vector.Storable+ ( module X+ ) where++import Data.Vector.Storable as X
+ src/RIO/Vector/Unboxed.hs view
@@ -0,0 +1,5 @@+module RIO.Vector.Unboxed+ ( module X+ ) where++import Data.Vector.Unboxed as X