diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +## 0.0 + +__NOTE__ All releases beginning with 0.0 are considered +experimental. Caveat emptor! diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,98 @@ +# The rio library + +*A standard library for Haskell* + +![Rio](https://camo.githubusercontent.com/fc162fb0024699c85f00eae769085a5fe528153e/68747470733a2f2f7777772e61687374617469632e636f6d2f70686f746f732f636974792f76692d76363837315f30305f31343030783434322e6a7067) + +__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/): + +![XKCD Standards](https://imgs.xkcd.com/comics/standards.png) + +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 diff --git a/rio.cabal b/rio.cabal new file mode 100644 --- /dev/null +++ b/rio.cabal @@ -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 +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 diff --git a/src/RIO.hs b/src/RIO.hs new file mode 100644 --- /dev/null +++ b/src/RIO.hs @@ -0,0 +1,4 @@ +module RIO (module X) where + +import RIO.Prelude as X +import RIO.Logger as X diff --git a/src/RIO/ByteString.hs b/src/RIO/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/RIO/ByteString.hs @@ -0,0 +1,5 @@ +module RIO.ByteString + ( module X + ) where + +import Data.ByteString as X diff --git a/src/RIO/ByteString/Lazy.hs b/src/RIO/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/RIO/ByteString/Lazy.hs @@ -0,0 +1,5 @@ +module RIO.ByteString.Lazy + ( module X + ) where + +import Data.ByteString.Lazy as X diff --git a/src/RIO/Directory.hs b/src/RIO/Directory.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Directory.hs @@ -0,0 +1,6 @@ +-- FIXME lift/unlift functions +module RIO.Directory + ( module X + ) where + +import System.Directory as X diff --git a/src/RIO/FilePath.hs b/src/RIO/FilePath.hs new file mode 100644 --- /dev/null +++ b/src/RIO/FilePath.hs @@ -0,0 +1,5 @@ +module RIO.FilePath + ( module X + ) where + +import System.FilePath as X diff --git a/src/RIO/HashMap.hs b/src/RIO/HashMap.hs new file mode 100644 --- /dev/null +++ b/src/RIO/HashMap.hs @@ -0,0 +1,5 @@ +module RIO.HashMap + ( module X + ) where + +import Data.HashMap.Strict as X diff --git a/src/RIO/HashSet.hs b/src/RIO/HashSet.hs new file mode 100644 --- /dev/null +++ b/src/RIO/HashSet.hs @@ -0,0 +1,5 @@ +module RIO.HashSet + ( module X + ) where + +import Data.HashSet as X diff --git a/src/RIO/List.hs b/src/RIO/List.hs new file mode 100644 --- /dev/null +++ b/src/RIO/List.hs @@ -0,0 +1,5 @@ +module RIO.List + ( module X + ) where + +import Data.List as X diff --git a/src/RIO/Logger.hs b/src/RIO/Logger.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Logger.hs @@ -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 + [] -> "" + (_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 diff --git a/src/RIO/Map.hs b/src/RIO/Map.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Map.hs @@ -0,0 +1,5 @@ +module RIO.Map + ( module X + ) where + +import Data.Map.Strict as X diff --git a/src/RIO/Prelude.hs b/src/RIO/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Prelude.hs @@ -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 #-} diff --git a/src/RIO/Process.hs b/src/RIO/Process.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Process.hs @@ -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) diff --git a/src/RIO/Set.hs b/src/RIO/Set.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Set.hs @@ -0,0 +1,5 @@ +module RIO.Set + ( module X + ) where + +import Data.Set as X diff --git a/src/RIO/Text.hs b/src/RIO/Text.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Text.hs @@ -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) diff --git a/src/RIO/Text/Lazy.hs b/src/RIO/Text/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Text/Lazy.hs @@ -0,0 +1,5 @@ +module RIO.Text.Lazy + ( module X + ) where + +import Data.Text.Lazy as X diff --git a/src/RIO/Time.hs b/src/RIO/Time.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Time.hs @@ -0,0 +1,5 @@ +module RIO.Time + ( module X + ) where + +import Data.Time as X diff --git a/src/RIO/Vector.hs b/src/RIO/Vector.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Vector.hs @@ -0,0 +1,5 @@ +module RIO.Vector + ( module X + ) where + +import Data.Vector.Generic as X diff --git a/src/RIO/Vector/Boxed.hs b/src/RIO/Vector/Boxed.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Vector/Boxed.hs @@ -0,0 +1,5 @@ +module RIO.Vector.Boxed + ( module X + ) where + +import Data.Vector as X diff --git a/src/RIO/Vector/Storable.hs b/src/RIO/Vector/Storable.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Vector/Storable.hs @@ -0,0 +1,5 @@ +module RIO.Vector.Storable + ( module X + ) where + +import Data.Vector.Storable as X diff --git a/src/RIO/Vector/Unboxed.hs b/src/RIO/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Vector/Unboxed.hs @@ -0,0 +1,5 @@ +module RIO.Vector.Unboxed + ( module X + ) where + +import Data.Vector.Unboxed as X