diff --git a/rio.cabal b/rio.cabal --- a/rio.cabal +++ b/rio.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: b145872fb20aa54d9368a8b9e4e820734cd2407c637e85881fdb54f7bab1639b +-- hash: 613b330708b2a2c48f3062883ce3b2dac673747a9d552e04e84685747f23f911 name: rio -version: 0.0.1.0 +version: 0.0.2.0 synopsis: A standard library for Haskell description: Work in progress library, see README at category: Control @@ -40,6 +40,7 @@ , hashable , microlens , mtl + , primitive , text , time , typed-process >=0.2.1.0 @@ -75,4 +76,42 @@ RIO.Vector.Unboxed other-modules: RIO.Prelude + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + build-depends: + base >=4.9 && <10 + , bytestring + , containers + , deepseq + , directory + , exceptions + , filepath + , hashable + , hspec + , microlens + , mtl + , primitive + , rio + , 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 + other-modules: + RIO.LoggerSpec + RIO.PreludeSpec + Paths_rio default-language: Haskell2010 diff --git a/src/RIO/ByteString/Lazy.hs b/src/RIO/ByteString/Lazy.hs --- a/src/RIO/ByteString/Lazy.hs +++ b/src/RIO/ByteString/Lazy.hs @@ -1,3 +1,6 @@ +-- | Lazy @ByteString@. Import as: +-- +-- > import qualified RIO.ByteString.Lazy as B.Lazy module RIO.ByteString.Lazy ( module Data.ByteString.Lazy ) where diff --git a/src/RIO/HashMap.hs b/src/RIO/HashMap.hs --- a/src/RIO/HashMap.hs +++ b/src/RIO/HashMap.hs @@ -1,3 +1,6 @@ +-- | Strict @Map@ with hashed keys. Import as: +-- +-- > import qualified RIO.HashMap as M.Hash module RIO.HashMap ( module Data.HashMap.Strict ) where diff --git a/src/RIO/HashSet.hs b/src/RIO/HashSet.hs --- a/src/RIO/HashSet.hs +++ b/src/RIO/HashSet.hs @@ -1,3 +1,6 @@ +-- | @Set@ with hashed members. Import as: +-- +-- > import qualified RIO.HashSet as S.Hash module RIO.HashSet ( module Data.HashSet ) where diff --git a/src/RIO/List.hs b/src/RIO/List.hs --- a/src/RIO/List.hs +++ b/src/RIO/List.hs @@ -1,3 +1,6 @@ +-- | @List@. Import as: +-- +-- > import qualified RIO.List as L module RIO.List ( module Data.List ) where diff --git a/src/RIO/Logger.hs b/src/RIO/Logger.hs --- a/src/RIO/Logger.hs +++ b/src/RIO/Logger.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module RIO.Logger ( LogLevel (..) , LogSource @@ -24,6 +26,7 @@ , withStickyLogger , LogOptions (..) , displayCallStack + , mkLogOptions ) where import RIO.Prelude @@ -35,11 +38,14 @@ import GHC.Stack (HasCallStack, CallStack, SrcLoc (..), getCallStack, callStack) import Data.Time import qualified Data.Text.IO as TIO -import Data.ByteString.Builder (toLazyByteString, char7) +import Data.ByteString.Builder (toLazyByteString, char7, byteString) +import Data.ByteString.Builder.Extra (flush) import GHC.IO.Handle.Internals (wantWritableHandle) import GHC.IO.Encoding.Types (textEncodingName) import GHC.IO.Handle.Types (Handle__ (..)) import qualified Data.ByteString as B +import System.IO (localeEncoding) +import GHC.Foreign (peekCString, withCString) data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther !Text deriving (Eq, Show, Read, Ord) @@ -48,6 +54,8 @@ type LogStr = DisplayBuilder class HasLogFunc env where logFuncL :: SimpleGetter env LogFunc +instance HasLogFunc LogFunc where + logFuncL = id type LogFunc = CallStack -> LogSource -> LogLevel -> LogStr -> IO () @@ -151,32 +159,55 @@ -- 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 +mkLogOptions + :: MonadIO m + => Handle + -> Bool -- ^ verbose? + -> m LogOptions +mkLogOptions handle verbose = liftIO $ do + terminal <- hIsTerminalDevice handle + useUtf8 <- canUseUtf8 handle + unicode <- if useUtf8 then return True else getCanUseUnicode + return LogOptions + { logMinLevel = if verbose then LevelDebug else LevelInfo + , logVerboseFormat = verbose + , logTerminal = terminal + , logUseTime = verbose + , logUseColor = verbose + , logSend = \builder -> + if useUtf8 && unicode + then hPutBuilder handle (builder <> flush) + else do + let lbs = toLazyByteString builder 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 + case decodeUtf8' bs of + Left e -> error $ "mkLogOptions: invalid UTF8 sequence: " ++ show (e, bs) + Right text -> do + let text' + | unicode = text + | otherwise = T.map replaceUnicode text + TIO.hPutStr handle text' + hFlush handle + } + +-- | Taken from GHC: determine if we should use Unicode syntax +getCanUseUnicode :: IO Bool +getCanUseUnicode = do + let enc = localeEncoding + str = "\x2018\x2019" + test = withCString enc str $ \cstr -> do + str' <- peekCString enc cstr + return (str == str') + test `catchIO` \_ -> return False + +withStickyLogger :: MonadUnliftIO m => LogOptions -> (LogFunc -> m a) -> m a +withStickyLogger options inner = withRunInIO $ \run -> do if logTerminal options - then withSticky $ \var -> - inner $ stickyImpl var options (simpleLogFunc options printer) + then withSticky options $ \var -> + run $ inner $ stickyImpl var options (simpleLogFunc options) else - inner $ \cs src level str -> - simpleLogFunc options printer cs src (noSticky level) str + run $ inner $ \cs src level str -> + simpleLogFunc options cs src (noSticky level) str -- | Replace Unicode characters with non-Unicode equivalents replaceUnicode :: Char -> Char @@ -195,17 +226,16 @@ , logTerminal :: !Bool , logUseTime :: !Bool , logUseColor :: !Bool - , logUseUnicode :: !Bool + , logSend :: !(Builder -> IO ()) } -simpleLogFunc :: LogOptions -> (LogStr -> IO ()) -> LogFunc -simpleLogFunc lo printer cs _src level msg = +simpleLogFunc :: LogOptions -> LogFunc +simpleLogFunc lo cs _src level msg = when (level >= logMinLevel lo) $ do timestamp <- getTimestamp - printer $ + logSend lo $ getUtf8Builder $ timestamp <> getLevel <> - " " <> ansi reset <> msg <> getLoc <> @@ -238,10 +268,10 @@ getLevel | logVerboseFormat lo = case level of - LevelDebug -> ansi setGreen <> "[debug]" - LevelInfo -> ansi setBlue <> "[info]" - LevelWarn -> ansi setYellow <> "[warn]" - LevelError -> ansi setRed <> "[error]" + LevelDebug -> ansi setGreen <> "[debug] " + LevelInfo -> ansi setBlue <> "[info] " + LevelWarn -> ansi setYellow <> "[warn] " + LevelError -> ansi setRed <> "[error] " LevelOther name -> ansi setMagenta <> "[" <> @@ -278,7 +308,7 @@ 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 + clear = logSend lo (repeating backSpaceChar <> repeating ' ' <> repeating backSpaceChar) @@ -287,33 +317,25 @@ 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 + logSend lo (byteString bs <> flush) return bs _ | level >= logMinLevel lo -> do clear logFunc loc src level msgOrig - unless (B.null sticky) $ do - B.hPut stderr sticky - hFlush stderr + unless (B.null sticky) $ logSend lo (byteString sticky <> flush) 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 +withSticky :: LogOptions -> (MVar ByteString -> IO b) -> IO b +withSticky lo inner = bracket + (newMVar mempty) + (\state -> do + state' <- takeMVar state + unless (B.null state') (logSend lo "\n")) + inner diff --git a/src/RIO/Map.hs b/src/RIO/Map.hs --- a/src/RIO/Map.hs +++ b/src/RIO/Map.hs @@ -1,3 +1,6 @@ +-- | Strict @Map@. Import as: +-- +-- > import qualified RIO.Map as M module RIO.Map ( module Data.Map.Strict ) where diff --git a/src/RIO/Prelude.hs b/src/RIO/Prelude.hs --- a/src/RIO/Prelude.hs +++ b/src/RIO/Prelude.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeSynonymInstances #-} module RIO.Prelude ( module UnliftIO + , UnliftIO.Concurrent.threadDelay , mapLeft , withLazyFile , fromFirst @@ -272,6 +273,16 @@ , System.Exit.ExitCode(..) , Text.Read.Read , Text.Read.readMaybe + -- * Primitive + , PrimMonad (..) + -- * Unboxed references + , Unbox + , URef + , IOURef + , newURef + , readURef + , writeURef + , modifyURef -- List imports from UnliftIO? ) where @@ -279,6 +290,7 @@ import Control.Applicative (Applicative) import Control.Monad (Monad (..), liftM, (<=<)) import Control.Monad.Catch (MonadThrow) +import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.Reader (MonadReader, ReaderT (..), ask, asks) import Data.Bool (otherwise) import Data.ByteString (ByteString) @@ -301,6 +313,7 @@ import Lens.Micro (Getting) import Prelude (FilePath, IO, Show (..)) import UnliftIO +import qualified UnliftIO.Concurrent -- import UnliftIO (Exception, Handle, IOMode (..), -- MonadIO (..), MonadUnliftIO, -- Typeable, UnliftIO (..), throwIO, @@ -315,6 +328,8 @@ import qualified Data.Vector.Generic as GVector import qualified Data.Vector.Storable as SVector import qualified Data.Vector.Unboxed as UVector +import qualified Data.Vector.Unboxed.Mutable as MUVector +import Data.Vector.Unboxed.Mutable (Unbox) import qualified Data.ByteString.Builder as BB import qualified Data.Semigroup @@ -522,3 +537,47 @@ hPutBuilder :: MonadIO m => Handle -> Builder -> m () hPutBuilder h = liftIO . BB.hPutBuilder h {-# INLINE hPutBuilder #-} + +-- | An unboxed reference. This works like an 'IORef', but the data is +-- stored in a bytearray instead of a heap object, avoiding +-- significant allocation overhead in some cases. For a concrete +-- example, see this Stack Overflow question: +-- . +-- +-- The first parameter is the state token type, the same as would be +-- used for the 'ST' monad. If you're using an 'IO'-based monad, you +-- can use the convenience 'IOURef' type synonym instead. +-- +-- @since 0.0.2.0 +newtype URef s a = URef (MUVector.MVector s a) + +-- | Helpful type synonym for using a 'URef' from an 'IO'-based stack. +-- +-- @since 0.0.2.0 +type IOURef = URef (PrimState IO) + +-- | Create a new 'URef' +-- +-- @since 0.0.2.0 +newURef :: (PrimMonad m, Unbox a) => a -> m (URef (PrimState m) a) +newURef a = fmap URef (MUVector.replicate 1 a) + +-- | Read the value in a 'URef' +-- +-- @since 0.0.2.0 +readURef :: (PrimMonad m, Unbox a) => URef (PrimState m) a -> m a +readURef (URef v) = MUVector.unsafeRead v 0 + +-- | Write a value into a 'URef'. Note that this action is strict, and +-- will force evalution of the value. +-- +-- @since 0.0.2.0 +writeURef :: (PrimMonad m, Unbox a) => URef (PrimState m) a -> a -> m () +writeURef (URef v) = MUVector.unsafeWrite v 0 + +-- | Modify a value in a 'URef'. Note that this action is strict, and +-- will force evaluation of the result value. +-- +-- @since 0.0.2.0 +modifyURef :: (PrimMonad m, Unbox a) => URef (PrimState m) a -> (a -> a) -> m () +modifyURef u f = readURef u >>= writeURef u . f diff --git a/src/RIO/Set.hs b/src/RIO/Set.hs --- a/src/RIO/Set.hs +++ b/src/RIO/Set.hs @@ -1,3 +1,6 @@ +-- | @Set@. Import as: +-- +-- > import qualified RIO.Set as S module RIO.Set ( module Data.Set ) where diff --git a/src/RIO/Text.hs b/src/RIO/Text.hs --- a/src/RIO/Text.hs +++ b/src/RIO/Text.hs @@ -1,3 +1,6 @@ +-- | Strict @Text@. Import as: +-- +-- > import qualified RIO.Text as T module RIO.Text ( module Data.Text , Data.Text.Encoding.encodeUtf8 diff --git a/src/RIO/Text/Lazy.hs b/src/RIO/Text/Lazy.hs --- a/src/RIO/Text/Lazy.hs +++ b/src/RIO/Text/Lazy.hs @@ -1,3 +1,6 @@ +-- | Lazy @Text@. Import as: +-- +-- > import qualified RIO.Text.Lazy as T.Lazy module RIO.Text.Lazy ( module Data.Text.Lazy ) where diff --git a/src/RIO/Vector.hs b/src/RIO/Vector.hs --- a/src/RIO/Vector.hs +++ b/src/RIO/Vector.hs @@ -1,3 +1,6 @@ +-- | Generic @Vector@ interface. Import as: +-- +-- > import qualified RIO.Vector as V module RIO.Vector ( module Data.Vector.Generic ) where diff --git a/src/RIO/Vector/Boxed.hs b/src/RIO/Vector/Boxed.hs --- a/src/RIO/Vector/Boxed.hs +++ b/src/RIO/Vector/Boxed.hs @@ -1,3 +1,6 @@ +-- | Boxed @Vector@. Import as: +-- +-- > import qualified RIO.Vector.Boxed as V.Boxed module RIO.Vector.Boxed ( module Data.Vector ) where diff --git a/src/RIO/Vector/Storable.hs b/src/RIO/Vector/Storable.hs --- a/src/RIO/Vector/Storable.hs +++ b/src/RIO/Vector/Storable.hs @@ -1,3 +1,6 @@ +-- | Storable @Vector@. Import as: +-- +-- > import qualified RIO.Vector.Storable as V.Storable module RIO.Vector.Storable ( module Data.Vector.Storable ) where diff --git a/src/RIO/Vector/Unboxed.hs b/src/RIO/Vector/Unboxed.hs --- a/src/RIO/Vector/Unboxed.hs +++ b/src/RIO/Vector/Unboxed.hs @@ -1,3 +1,6 @@ +-- | Unboxed @Vector@. Import as: +-- +-- > import qualified RIO.Vector.Unboxed as V.Unboxed module RIO.Vector.Unboxed ( module Data.Vector.Unboxed ) where diff --git a/test/RIO/LoggerSpec.hs b/test/RIO/LoggerSpec.hs new file mode 100644 --- /dev/null +++ b/test/RIO/LoggerSpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module RIO.LoggerSpec (spec) where + +import Test.Hspec +import RIO +import Data.ByteString.Builder (toLazyByteString) + +spec :: Spec +spec = do + it "sanity" $ do + ref <- newIORef mempty + let options = LogOptions + { logMinLevel = LevelInfo + , logVerboseFormat = False + , logTerminal = True + , logUseTime = False + , logUseColor = False + , logSend = \builder -> modifyIORef ref (<> builder) + } + withStickyLogger options $ \lf -> runRIO lf $ do + logDebug "should not appear" + logInfo "should appear" + builder <- readIORef ref + toLazyByteString builder `shouldBe` "should appear\n" + it "sticky" $ do + ref <- newIORef mempty + let options = LogOptions + { logMinLevel = LevelInfo + , logVerboseFormat = False + , logTerminal = True + , logUseTime = False + , logUseColor = False + , logSend = \builder -> modifyIORef ref (<> builder) + } + withStickyLogger options $ \lf -> runRIO lf $ do + logSticky "ABC" + logDebug "should not appear" + logInfo "should appear" + logStickyDone "XYZ" + builder <- readIORef ref + toLazyByteString builder `shouldBe` "ABC\b\b\b \b\b\bshould appear\nABC\b\b\b \b\b\bXYZ\n" diff --git a/test/RIO/PreludeSpec.hs b/test/RIO/PreludeSpec.hs new file mode 100644 --- /dev/null +++ b/test/RIO/PreludeSpec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module RIO.PreludeSpec (spec) where + +import Test.Hspec +import RIO +import Data.ByteString.Builder (toLazyByteString) + +spec :: Spec +spec = do + it "sanity" $ do + ref <- newURef (0 :: Int) + x <- readURef ref + x `shouldBe` 0 + writeURef ref 1 + y <- readURef ref + y `shouldBe` 1 + modifyURef ref (+ 1) + z <- readURef ref + z `shouldBe` 2 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}