diff --git a/library/Ptr/Poke.hs b/library/Ptr/Poke.hs --- a/library/Ptr/Poke.hs +++ b/library/Ptr/Poke.hs @@ -54,3 +54,18 @@ pokeAndPeek :: B.PokeAndPeek input output -> Poke input pokeAndPeek (B.PokeAndPeek size io _) = Poke size io + +{-# INLINE asciiChar #-} +asciiChar :: Poke Char +asciiChar = + contramap (fromIntegral . ord) word8 + +{-# INLINE asciiDigit #-} +asciiDigit :: Poke Word8 +asciiDigit = + contramap (+ 48) word8 + +{-# INLINE asciiHexDigit #-} +asciiHexDigit :: Poke Word8 +asciiHexDigit = + contramap (\ n -> if n < 10 then 48 + n else 55 + n) word8 diff --git a/library/Ptr/PokeIO.hs b/library/Ptr/PokeIO.hs new file mode 100644 --- /dev/null +++ b/library/Ptr/PokeIO.hs @@ -0,0 +1,27 @@ +{-| +Sketches of new module, which implements the poking actions. +-} +module Ptr.PokeIO +where + +import Ptr.Prelude + + +type PokeIO = + Ptr Word8 -> IO () + +{-# INLINE sequentially #-} +sequentially :: Int -> PokeIO -> PokeIO -> PokeIO +sequentially space1 action1 action2 ptr = + action1 ptr *> action2 (plusPtr ptr space1) + +{-# INLINE concurrently #-} +concurrently :: Int -> PokeIO -> PokeIO -> PokeIO +concurrently space1 action1 action2 ptr = + do + lock <- newEmptyMVar + forkIO $ do + action1 ptr + putMVar lock () + action2 (plusPtr ptr space1) + takeMVar lock diff --git a/library/Ptr/Poking.hs b/library/Ptr/Poking.hs --- a/library/Ptr/Poking.hs +++ b/library/Ptr/Poking.hs @@ -5,6 +5,7 @@ import qualified Ptr.IO as A import qualified Ptr.Poke as C import qualified Ptr.PokeAndPeek as D +import qualified Ptr.PokeIO as E import qualified Data.ByteString.Internal as B @@ -22,9 +23,18 @@ Poking !Int !(Ptr Word8 -> IO ()) instance Semigroup Poking where - {-# INLINE (<>) #-} + {-| + When the pokings are both larger than 2048 bits, + the serialization is performed concurrently. + -} + {-# INLINABLE (<>) #-} (<>) (Poking space1 action1) (Poking space2 action2) = - Poking (space1 + space2) (\ptr -> action1 ptr *> action2 (plusPtr ptr space1)) + Poking (space1 + space2) action + where + action = + if space1 < 2048 || space2 < 2048 + then E.sequentially space1 action1 action2 + else E.concurrently space1 action1 action2 instance Monoid Poking where {-# INLINE mempty #-} @@ -34,25 +44,6 @@ mappend = (<>) -{-| -Same as 'mappend' and '<>', -but performs the serialization concurrently. -This comes at the cost of an overhead, -so it is only advised to use this function when the merged serializations are heavy. --} -prependConc :: Poking -> Poking -> Poking -prependConc (Poking space1 action1) (Poking space2 action2) = - Poking (space1 + space2) action - where - action ptr = - do - lock <- newEmptyMVar - forkIO $ do - action1 ptr - putMVar lock () - action2 (plusPtr ptr space1) - takeMVar lock - {-# INLINE word8 #-} word8 :: Word8 -> Poking word8 x = @@ -103,37 +94,37 @@ (quot, rem) -> loop (word8 (48 + fromIntegral rem) <> builder) quot -{-# INLINABLE paddedAndTrimmedAsciiIntegral #-} -paddedAndTrimmedAsciiIntegral :: Integral a => Int -> a -> Poking -paddedAndTrimmedAsciiIntegral !length !integral = +{-# INLINE asciiChar #-} +asciiChar :: Char -> Poking +asciiChar = + word8 . fromIntegral . ord + +{-# INLINABLE asciiPaddedAndTrimmedIntegral #-} +asciiPaddedAndTrimmedIntegral :: Integral a => Int -> a -> Poking +asciiPaddedAndTrimmedIntegral !length !integral = if length > 0 then if integral >= 0 then case quotRem integral 10 of (quot, rem) -> - paddedAndTrimmedAsciiIntegral (pred length) quot <> + asciiPaddedAndTrimmedIntegral (pred length) quot <> word8 (48 + fromIntegral rem) else stimes length (word8 48) else mempty -{-# INLINE asciiChar #-} -asciiChar :: Char -> Poking -asciiChar = - word8 . fromIntegral . ord - -{-# INLINABLE utcTimeInIso8601InAscii #-} +{-# INLINABLE asciiUtcTimeInIso8601 #-} {- 2017-02-01T05:03:58Z -} -utcTimeInIso8601InAscii :: UTCTime -> Poking -utcTimeInIso8601InAscii utcTime = - paddedAndTrimmedAsciiIntegral 4 year <> word8 45 <> - paddedAndTrimmedAsciiIntegral 2 month <> word8 45 <> - paddedAndTrimmedAsciiIntegral 2 day <> +asciiUtcTimeInIso8601 :: UTCTime -> Poking +asciiUtcTimeInIso8601 utcTime = + asciiPaddedAndTrimmedIntegral 4 year <> word8 45 <> + asciiPaddedAndTrimmedIntegral 2 month <> word8 45 <> + asciiPaddedAndTrimmedIntegral 2 day <> word8 84 <> - paddedAndTrimmedAsciiIntegral 2 hour <> word8 58 <> - paddedAndTrimmedAsciiIntegral 2 minute <> word8 58 <> - paddedAndTrimmedAsciiIntegral 2 (round second) <> + asciiPaddedAndTrimmedIntegral 2 hour <> word8 58 <> + asciiPaddedAndTrimmedIntegral 2 minute <> word8 58 <> + asciiPaddedAndTrimmedIntegral 2 (round second) <> word8 90 where LocalTime date (TimeOfDay hour minute second) = utcToLocalTime utc utcTime diff --git a/ptr.cabal b/ptr.cabal --- a/ptr.cabal +++ b/ptr.cabal @@ -1,7 +1,7 @@ name: ptr version: - 0.15.7 + 0.16 category: Ptr, Data synopsis: @@ -50,6 +50,7 @@ other-modules: Ptr.Receive.Core Ptr.IO + Ptr.PokeIO Ptr.UncheckedShifting Ptr.Prelude build-depends: @@ -81,17 +82,18 @@ -threaded "-with-rtsopts=-N" default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 build-depends: -- ptr, -- testing: - tasty == 0.11.*, - tasty-quickcheck == 0.8.*, - tasty-hunit == 0.9.*, - quickcheck-instances >= 0.3.11 && < 0.4, + tasty >=0.12 && <0.13, + tasty-quickcheck >=0.9 && <0.10, + tasty-hunit >=0.9 && <0.10, + quickcheck-instances >=0.3.11 && <0.4, + QuickCheck >=2.8.1 && <3, -- bug == 1.*, rerebase == 1.* diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -31,13 +31,13 @@ , testGroup "Poking" [ - testCase "paddedAndTrimmedAsciiIntegral" $ do - assertEqual "" "001" (A.poking (F.paddedAndTrimmedAsciiIntegral 3 1)) - assertEqual "" "001" (A.poking (F.paddedAndTrimmedAsciiIntegral 3 2001)) - assertEqual "" "000" (A.poking (F.paddedAndTrimmedAsciiIntegral 3 (-1))) + testCase "asciiPaddedAndTrimmedIntegral" $ do + assertEqual "" "001" (A.poking (F.asciiPaddedAndTrimmedIntegral 3 1)) + assertEqual "" "001" (A.poking (F.asciiPaddedAndTrimmedIntegral 3 2001)) + assertEqual "" "000" (A.poking (F.asciiPaddedAndTrimmedIntegral 3 (-1))) , - testCase "utcTimeInIso8601InAscii" $ do - assertEqual "" "2017-02-01T05:03:58Z" (A.poking (F.utcTimeInIso8601InAscii (read "2017-02-01 05:03:58"))) + testCase "asciiUtcTimeInIso8601" $ do + assertEqual "" "2017-02-01T05:03:58Z" (A.poking (F.asciiUtcTimeInIso8601 (read "2017-02-01 05:03:58"))) ] ]