packages feed

rio 0.0.1.0 → 0.0.2.0

raw patch · 18 files changed

+272/−53 lines, 18 filesdep +hspecdep +primitivedep +rio

Dependencies added: hspec, primitive, rio

Files

rio.cabal view
@@ -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 <https://github.com/commercialhaskell/rio#readme> 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
src/RIO/ByteString/Lazy.hs view
@@ -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
src/RIO/HashMap.hs view
@@ -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
src/RIO/HashSet.hs view
@@ -1,3 +1,6 @@+-- | @Set@ with hashed members. Import as:+--+-- > import qualified RIO.HashSet as S.Hash module RIO.HashSet   ( module Data.HashSet   ) where
src/RIO/List.hs view
@@ -1,3 +1,6 @@+-- | @List@. Import as:+--+-- > import qualified RIO.List as L module RIO.List   ( module Data.List   ) where
src/RIO/Logger.hs view
@@ -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
src/RIO/Map.hs view
@@ -1,3 +1,6 @@+-- | Strict @Map@. Import as:+--+-- > import qualified RIO.Map as M module RIO.Map   ( module Data.Map.Strict   ) where
src/RIO/Prelude.hs view
@@ -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:+-- <https://stackoverflow.com/questions/27261813/why-is-my-little-stref-int-require-allocating-gigabytes>.+--+-- 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
src/RIO/Set.hs view
@@ -1,3 +1,6 @@+-- | @Set@. Import as:+--+-- > import qualified RIO.Set as S module RIO.Set   ( module Data.Set   ) where
src/RIO/Text.hs view
@@ -1,3 +1,6 @@+-- | Strict @Text@. Import as:+--+-- > import qualified RIO.Text as T module RIO.Text   ( module Data.Text   , Data.Text.Encoding.encodeUtf8
src/RIO/Text/Lazy.hs view
@@ -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
src/RIO/Vector.hs view
@@ -1,3 +1,6 @@+-- | Generic @Vector@ interface. Import as:+--+-- > import qualified RIO.Vector as V module RIO.Vector   ( module Data.Vector.Generic   ) where
src/RIO/Vector/Boxed.hs view
@@ -1,3 +1,6 @@+-- | Boxed @Vector@. Import as:+--+-- > import qualified RIO.Vector.Boxed as V.Boxed module RIO.Vector.Boxed   ( module Data.Vector   ) where
src/RIO/Vector/Storable.hs view
@@ -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
src/RIO/Vector/Unboxed.hs view
@@ -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
+ test/RIO/LoggerSpec.hs view
@@ -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"
+ test/RIO/PreludeSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}