persist 0.1.1.2 → 0.1.1.3
raw patch · 3 files changed
+246/−171 lines, 3 files
Files
- persist.cabal +3/−2
- src/Data/Persist.hs +6/−169
- src/Data/Persist/Internal.hs +237/−0
persist.cabal view
@@ -1,5 +1,5 @@ name: persist-version: 0.1.1.2+version: 0.1.1.3 license: BSD3 license-file: LICENSE author: Daniel Mendler <mail@daniel-mendler.de>,@@ -44,7 +44,8 @@ hs-source-dirs: src - exposed-modules: Data.Persist+ exposed-modules: Data.Persist,+ Data.Persist.Internal ghc-options: -Wall -O2 -funbox-strict-fields
src/Data/Persist.hs view
@@ -58,33 +58,28 @@ , putBE ) where -import Control.Exception import Control.Monad import Data.Bits import Data.ByteString (ByteString)-import Data.Foldable (foldlM)-import Data.IORef import Data.Int import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.List (unfoldr) import Data.List.NonEmpty (NonEmpty(..)) import Data.Map (Map)+import Data.Persist.Internal import Data.Proxy import Data.Sequence (Seq) import Data.Set (Set) import Data.Text (Text) import Data.Word-import Foreign (ForeignPtr, Ptr, Storable(..), plusPtr, minusPtr, castPtr,- withForeignPtr, mallocBytes, free, allocaBytes)+import Foreign (Ptr, Storable(..), plusPtr, minusPtr, castPtr, withForeignPtr) import GHC.Base (unsafeChr, ord) import GHC.Exts (IsList(..)) import GHC.Generics import GHC.Real (Ratio(..)) import GHC.TypeLits import Numeric.Natural-import System.IO.Unsafe-import qualified Control.Monad.Fail as Fail import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as L@@ -96,9 +91,6 @@ #include "MachDeps.h" -data a :!: b = !a :!: !b-infixl 2 :!:- putHE :: Persist (HostEndian a) => a -> Put () getHE :: Persist (HostEndian a) => Get a {-# INLINE putHE #-}@@ -785,7 +777,7 @@ if r <= 0x10FFFF then pure $ unsafeChr r else- fail "Invalid character"+ failGet CharException "Invalid character" {-# INLINE get #-} instance Persist Text where@@ -989,69 +981,13 @@ cur = fromInteger (natVal (Proxy :: Proxy n)) {-# INLINE ggetSum #-} -data GetEnv = GetEnv- { geBuf :: !(ForeignPtr Word8)- , geBegin :: !(Ptr Word8)- , geEnd :: !(Ptr Word8)- , geTmp :: !(Ptr Word8)- }--newtype Get a = Get- { unGet :: GetEnv -> Ptr Word8 -> IO (Ptr Word8 :!: a)- }--instance Functor Get where- fmap f m = Get $ \e p -> do- p' :!: x <- unGet m e p- pure $! p' :!: f x- {-# INLINE fmap #-}--instance Applicative Get where- pure a = Get $ \_ p -> pure $! p :!: a- {-# INLINE pure #-}-- f <*> a = Get $ \e p -> do- p' :!: f' <- unGet f e p- p'' :!: a' <- unGet a e p'- pure $! p'' :!: f' a'- {-# INLINE (<*>) #-}-- m1 *> m2 = do- void m1- m2- {-# INLINE (*>) #-}--instance Monad Get where- m >>= f = Get $ \e p -> do- p' :!: x <- unGet m e p- unGet (f x) e p'- {-# INLINE (>>=) #-}-- fail = Fail.fail- {-# INLINE fail #-}--instance Fail.MonadFail Get where- fail msg = Get $ \_ _ -> fail $ "Failed reading: " <> msg- {-# INLINE fail #-}---- | Run the Get monad applies a 'get'-based parser on the input ByteString-runGet :: Get a -> ByteString -> Either String a-runGet m s = unsafePerformIO $ catch run handler- where run = withForeignPtr buf $ \p -> allocaBytes 8 $ \t -> do- let env = GetEnv { geBuf = buf, geBegin = p, geEnd = p `plusPtr` (pos + len), geTmp = t }- _ :!: r <- unGet m env (p `plusPtr` pos)- pure $ Right r- handler (e :: IOException) = pure $ Left $ displayException e- (B.PS buf pos len) = s-{-# NOINLINE runGet #-}- -- | Ensure that @n@ bytes are available. Fails if fewer than @n@ bytes are available. ensure :: Int -> Get () ensure n- | n < 0 = fail "ensure: negative length"+ | n < 0 = failGet LengthException "ensure: negative length" | otherwise = do m <- remaining- when (m < n) $ fail "Not enough bytes available"+ when (m < n) $ failGet LengthException "Not enough bytes available" {-# INLINE ensure #-} -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available.@@ -1071,7 +1007,7 @@ eof :: Get () eof = do n <- remaining- when (n /= 0) $ fail "Expected end of file"+ when (n /= 0) $ failGet EOFException "Expected end of file" {-# INLINE eof #-} -- | Pull @n@ bytes from the input, as a strict ByteString.@@ -1088,108 +1024,9 @@ getByteString n = B.copy <$!> getBytes n {-# INLINE getByteString #-} -data Chunk = Chunk- { chkBegin :: !(Ptr Word8)- , chkEnd :: !(Ptr Word8)- }--data PutEnv = PutEnv- { peChks :: !(IORef (NonEmpty Chunk))- , peEnd :: !(IORef (Ptr Word8))- , peTmp :: !(Ptr Word8)- }--newtype Put a = Put- { unPut :: PutEnv -> Ptr Word8 -> IO (Ptr Word8 :!: a) }--instance Functor Put where- fmap f m = Put $ \e p -> do- p' :!: x <- unPut m e p- pure $! p' :!: f x- {-# INLINE fmap #-}--instance Applicative Put where- pure a = Put $ \_ p -> pure $! p :!: a- {-# INLINE pure #-}-- f <*> a = Put $ \e p -> do- p' :!: f' <- unPut f e p- p'' :!: a' <- unPut a e p'- pure $! p'' :!: f' a'- {-# INLINE (<*>) #-}-- m1 *> m2 = do- void m1- m2- {-# INLINE (*>) #-}--instance Monad Put where- m >>= f = Put $ \e p -> do- p' :!: x <- unPut m e p- unPut (f x) e p'- {-# INLINE (>>=) #-}--minChunkSize :: Int-minChunkSize = 0x10000-{-# INLINE minChunkSize #-}--newChunk :: Int -> IO Chunk-newChunk size = do- let n = max size minChunkSize- p <- mallocBytes n- pure $! Chunk p $ p `plusPtr` n-{-# INLINE newChunk #-}--doGrow :: PutEnv -> Ptr Word8 -> Int -> IO (Ptr Word8 :!: ())-doGrow e p n = do- k <- newChunk n- modifyIORef' (peChks e) $ \case- (c:|cs) -> k :| c { chkEnd = p } : cs- writeIORef (peEnd e) (chkEnd k)- pure $! chkBegin k :!: ()-{-# NOINLINE doGrow #-}---- | Ensure that @n@ bytes can be written.-grow :: Int -> Put ()-grow n- | n < 0 = fail "grow: negative length"- | otherwise = Put $ \e p -> do- end <- readIORef (peEnd e)- if end `minusPtr` p >= n then- pure $! p :!: ()- else- doGrow e p n-{-# INLINE grow #-}- runPut :: Put a -> ByteString runPut = snd . evalPut {-# INLINE runPut #-}--chunksLength :: [Chunk] -> Int-chunksLength = foldr (\c s -> s + chkEnd c `minusPtr` chkBegin c) 0-{-# INLINE chunksLength #-}--catChunks :: [Chunk] -> IO ByteString-catChunks chks = B.create (chunksLength chks) $ \p ->- void $ foldlM (\q c -> do- let n = chkEnd c `minusPtr` chkBegin c- B.memcpy q (chkBegin c) n- free $ chkBegin c- pure (q `plusPtr` n)) p $ reverse chks-{-# INLINE catChunks #-}--evalPut :: Put a -> (a, ByteString)-evalPut p = unsafePerformIO $ do- k <- newChunk 0- chks <- newIORef (k:|[])- end <- newIORef (chkEnd k)- p' :!: r <- allocaBytes 8 $ \t ->- unPut p PutEnv { peChks = chks, peEnd = end, peTmp = t } (chkBegin k)- cs <- readIORef chks- s <- case cs of- (x:|xs) -> catChunks $ x { chkEnd = p' } : xs- pure (r, s)-{-# NOINLINE evalPut #-} putByteString :: ByteString -> Put () putByteString (B.PS b o n) = do
+ src/Data/Persist/Internal.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Persist.Internal (+ (:!:)(..)+ -- * The Get type+ , Get(..)+ , GetEnv(..)+ , GetException(..)+ , getOffset+ , failGet+ , runGet+ , runGetIO++ -- * The Put type+ , Put(..)+ , PutEnv(..)+ , Chunk(..)+ , evalPut+ , evalPutIO+ , grow+) where++import Control.Exception+import Control.Monad+import Data.ByteString (ByteString)+import Data.Foldable (foldlM)+import Data.IORef+import Data.List.NonEmpty (NonEmpty(..))+import Data.Word+import Foreign (ForeignPtr, Ptr, plusPtr, minusPtr,+ withForeignPtr, mallocBytes, free, allocaBytes)+import System.IO.Unsafe+import qualified Control.Monad.Fail as Fail+import qualified Data.ByteString.Internal as B++#include "MachDeps.h"++data a :!: b = !a :!: !b+infixl 2 :!:++data GetEnv = GetEnv+ { geBuf :: !(ForeignPtr Word8)+ , geBegin :: !(Ptr Word8)+ , geEnd :: !(Ptr Word8)+ , geTmp :: !(Ptr Word8)+ }++newtype Get a = Get+ { unGet :: GetEnv -> Ptr Word8 -> IO ((Ptr Word8) :!: a)+ }++instance Functor Get where+ fmap f m = Get $ \e p -> do+ p' :!: x <- unGet m e p+ pure $! p' :!: f x+ {-# INLINE fmap #-}++instance Applicative Get where+ pure a = Get $ \_ p -> pure $! p :!: a+ {-# INLINE pure #-}++ f <*> a = Get $ \e p -> do+ p' :!: f' <- unGet f e p+ p'' :!: a' <- unGet a e p'+ pure $! p'' :!: f' a'+ {-# INLINE (<*>) #-}++ m1 *> m2 = do+ void m1+ m2+ {-# INLINE (*>) #-}++instance Monad Get where+ m >>= f = Get $ \e p -> do+ p' :!: x <- unGet m e p+ unGet (f x) e p'+ {-# INLINE (>>=) #-}++ fail = Fail.fail+ {-# INLINE fail #-}++data GetException+ = LengthException Int String+ | CharException Int String+ | EOFException Int String+ | GenericGetException Int String+ deriving (Eq, Show)++instance Exception GetException++instance Fail.MonadFail Get where+ fail msg = failGet GenericGetException ("Failed reading: " <> msg)+ {-# INLINE fail #-}++getOffset :: Get Int+getOffset = Get $ \e p -> pure $! p :!: (p `minusPtr` (geBegin e))+{-# INLINE getOffset #-}++failGet :: (Int -> String -> GetException) -> String -> Get a+failGet ctor msg = do+ offset <- getOffset+ Get $ \_ _ -> throwIO (ctor offset msg)++runGetIO :: Get a -> ByteString -> IO a+runGetIO m s = run+ where run = withForeignPtr buf $ \p -> allocaBytes 8 $ \t -> do+ let env = GetEnv { geBuf = buf, geBegin = p, geEnd = p `plusPtr` (pos + len), geTmp = t }+ _ :!: r <- unGet m env (p `plusPtr` pos)+ pure r+ (B.PS buf pos len) = s++-- | Run the Get monad applies a 'get'-based parser on the input ByteString+runGet :: Get a -> ByteString -> Either String a+runGet m s = unsafePerformIO $ catch (Right <$!> (runGetIO m s)) handler+ where handler (e :: GetException) = pure $ Left $ displayException e+{-# NOINLINE runGet #-}++data Chunk = Chunk+ { chkBegin :: !(Ptr Word8)+ , chkEnd :: !(Ptr Word8)+ }++data PutEnv = PutEnv+ { peChks :: !(IORef (NonEmpty Chunk))+ , peEnd :: !(IORef (Ptr Word8))+ , peTmp :: !(Ptr Word8)+ }++newtype Put a = Put+ { unPut :: PutEnv -> Ptr Word8 -> IO ((Ptr Word8) :!: a) }++instance Functor Put where+ fmap f m = Put $ \e p -> do+ p' :!: x <- unPut m e p+ pure $! p' :!: f x+ {-# INLINE fmap #-}++instance Applicative Put where+ pure a = Put $ \_ p -> pure $! p :!: a+ {-# INLINE pure #-}++ f <*> a = Put $ \e p -> do+ p' :!: f' <- unPut f e p+ p'' :!: a' <- unPut a e p'+ pure $! p'' :!: f' a'+ {-# INLINE (<*>) #-}++ m1 *> m2 = do+ void m1+ m2+ {-# INLINE (*>) #-}++instance Monad Put where+ m >>= f = Put $ \e p -> do+ p' :!: x <- unPut m e p+ unPut (f x) e p'+ {-# INLINE (>>=) #-}++minChunkSize :: Int+minChunkSize = 0x10000+{-# INLINE minChunkSize #-}++newChunk :: Int -> IO Chunk+newChunk size = do+ let n = max size minChunkSize+ p <- mallocBytes n+ pure $! Chunk p $ p `plusPtr` n+{-# INLINE newChunk #-}++-- | Ensure that @n@ bytes can be written.+grow :: Int -> Put ()+grow n+ | n < 0 = fail "grow: negative length"+ | otherwise = Put $ \e p -> do+ end <- readIORef (peEnd e)+ if end `minusPtr` p >= n then+ pure $! p :!: ()+ else+ doGrow e p n+{-# INLINE grow #-}++doGrow :: PutEnv -> Ptr Word8 -> Int -> IO ((Ptr Word8) :!: ())+doGrow e p n = do+ k <- newChunk n+ modifyIORef' (peChks e) $ \case+ (c:|cs) -> k :| c { chkEnd = p } : cs+ writeIORef (peEnd e) (chkEnd k)+ pure $! chkBegin k :!: ()+{-# NOINLINE doGrow #-}++chunksLength :: [Chunk] -> Int+chunksLength = foldr (\c s -> s + chkEnd c `minusPtr` chkBegin c) 0+{-# INLINE chunksLength #-}++catChunks :: [Chunk] -> IO ByteString+catChunks chks = B.create (chunksLength chks) $ \p ->+ void $ foldlM (\q c -> do+ let n = chkEnd c `minusPtr` chkBegin c+ B.memcpy q (chkBegin c) n+ free $ chkBegin c+ pure (q `plusPtr` n)) p $ reverse chks+{-# INLINE catChunks #-}++evalPutIO :: Put a -> IO (a, ByteString)+evalPutIO p = do+ k <- newChunk 0+ chks <- newIORef (k:|[])+ end <- newIORef (chkEnd k)+ p' :!: r <- allocaBytes 8 $ \t ->+ unPut p PutEnv { peChks = chks, peEnd = end, peTmp = t } (chkBegin k)+ cs <- readIORef chks+ s <- case cs of+ (x:|xs) -> catChunks $ x { chkEnd = p' } : xs+ pure (r, s)++evalPut :: Put a -> (a, ByteString)+evalPut p = unsafePerformIO $ evalPutIO p+{-# NOINLINE evalPut #-}