diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2017, Nikita Volkov + +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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ascii-string.cabal b/ascii-string.cabal new file mode 100644 --- /dev/null +++ b/ascii-string.cabal @@ -0,0 +1,70 @@ +name: + ascii-string +version: + 1 +synopsis: + Compact representation of ASCII strings +description: + ASCII strings stored using just 7 bits per character. + Compared to ByteString, this saves you a whole byte per 8 characters. +homepage: + https://github.com/metrix-ai/ascii-string +bug-reports: + https://github.com/metrix-ai/ascii-string/issues +author: + Nikita Volkov +maintainer: + Metrix.AI Ninjas +copyright: + (c) 2018, Metrix.AI +license: + MIT +license-file: + LICENSE +build-type: + Simple +cabal-version: + >=1.10 + +library + hs-source-dirs: + library + 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 + default-language: + Haskell2010 + exposed-modules: + AsciiString + other-modules: + AsciiString.Prelude + AsciiString.FoldMs + build-depends: + base >=4.7 && <5, + bytestring >=0.10 && <0.11, + cereal >=0.5.5 && <0.6, + deferred-folds >=0.6.11 && <0.7, + foldl >=1.4 && <2, + hashable >=1.2.7 && <2, + primitive >=0.6.4 && <0.7, + primitive-extras >=0.6.3 && <0.7 + +test-suite test + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + 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 + default-language: + Haskell2010 + main-is: + Main.hs + build-depends: + ascii-string, + cereal, + QuickCheck >=2.8.1 && <3, + quickcheck-instances >=0.3.11 && <0.4, + rerebase <2, + tasty >=0.12 && <2, + tasty-hunit >=0.9 && <0.11, + tasty-quickcheck >=0.9 && <0.11 diff --git a/library/AsciiString.hs b/library/AsciiString.hs new file mode 100644 --- /dev/null +++ b/library/AsciiString.hs @@ -0,0 +1,104 @@ +module AsciiString +( + AsciiString, + length, + fromSeptetList, + fromByteString, + fromShortByteString, + toSeptetList, + toByteString, + toShortByteString, +) +where + +import AsciiString.Prelude hiding (length) +import qualified Data.List as List +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Short.Internal as ShortByteString +import qualified DeferredFolds.UnfoldM as UnfoldM +import qualified AsciiString.FoldMs as FoldMs +import qualified Control.Foldl as Foldl +import qualified PrimitiveExtras.PrimArray as PrimArray +import qualified Data.Serialize as Serialize + + +{-| +Compact representation of ASCII string. +-} +data AsciiString = AsciiString {-# UNPACK #-} !Int {-# UNPACK #-} !(PrimArray Word8) + +deriving instance Eq AsciiString +deriving instance Ord AsciiString +deriving instance Generic AsciiString + +instance Hashable AsciiString where + hashWithSalt salt (AsciiString size (PrimArray ba)) = + hashByteArrayWithSalt ba 0 size salt + +instance Show AsciiString where + show = show . toByteString + +instance IsString AsciiString where + fromString = fromSeptetList . fmap (fromIntegral . ord) + +instance Serialize AsciiString where + put (AsciiString size (PrimArray ba)) = do + Serialize.put size + Serialize.putShortByteString (ShortByteString.SBS ba) + get = do + septetsAmount <- Serialize.get + let octetsAmount = div ((septetsAmount + 1) * 7) 8 + ShortByteString.SBS ba <- Serialize.getShortByteString octetsAmount + return (AsciiString septetsAmount (PrimArray ba)) + + +{-| Get the amount of septets. -} +length :: AsciiString -> Int +length (AsciiString length _) = length + +{-| Construct from a list of septets encoded in 'Word8', ignoring the 8th bit. -} +fromSeptetList :: [Word8] -> AsciiString +fromSeptetList list = + fromUnfoldM (List.length list) (UnfoldM.foldable list) + +{-| +Convert from ByteString, ignoring each 8th bit in it. +-} +fromByteString :: ByteString -> AsciiString +fromByteString byteString = + fromUnfoldM (ByteString.length byteString) (UnfoldM.byteStringBytes byteString) + +{-| +Convert from ShortByteString, ignoring each 8th bit in it. +-} +fromShortByteString :: ShortByteString -> AsciiString +fromShortByteString byteString = + fromUnfoldM (ShortByteString.length byteString) (UnfoldM.shortByteStringBytes byteString) + +{-# INLINE fromUnfoldM #-} +fromUnfoldM :: Int -> UnfoldM IO Word8 -> AsciiString +fromUnfoldM size unfoldM = + AsciiString size (unsafeDupablePerformIO (UnfoldM.foldM (FoldMs.sizedSeptetPrimArrayFromSeptets size) unfoldM)) + +{-| Convert to a list of septets represented by 'Word8' with the 8th bit always empty. -} +toSeptetList :: AsciiString -> [Word8] +toSeptetList = unsafeDupablePerformIO . UnfoldM.foldM (Foldl.generalize Foldl.list) . toOctetUnfoldM + +{-| Convert to bytestring. -} +toByteString :: AsciiString -> ByteString +toByteString = unsafeDupablePerformIO . runSizedFoldM FoldMs.sizedByteStringFromOctets + +{-| Convert to short bytestring. -} +toShortByteString :: AsciiString -> ShortByteString +toShortByteString = primArraySBS . unsafeDupablePerformIO . runSizedFoldM PrimArray.elementsFoldM where + primArraySBS :: PrimArray Word8 -> ShortByteString + primArraySBS (PrimArray ba) = ShortByteString.SBS ba + +toOctetUnfoldM :: AsciiString -> UnfoldM IO Word8 +toOctetUnfoldM (AsciiString size pa) = let + takeLast = rem (7 * succ size) 8 /= 0 + in UnfoldM.mapFoldMInput (FoldMs.overSeptets takeLast) (UnfoldM.primArray pa) + +runSizedFoldM :: (Int -> FoldM IO Word8 output) -> AsciiString -> IO output +runSizedFoldM fold asciiString = + UnfoldM.foldM (fold (length asciiString)) (toOctetUnfoldM asciiString) diff --git a/library/AsciiString/FoldMs.hs b/library/AsciiString/FoldMs.hs new file mode 100644 --- /dev/null +++ b/library/AsciiString/FoldMs.hs @@ -0,0 +1,67 @@ +module AsciiString.FoldMs +where + +import AsciiString.Prelude +import qualified Data.ByteString.Internal as ByteString + + +{-| +Converts a fold over septets (still encoded in octets) into a fold over actual octets. +-} +overSeptets :: Monad m => Bool -> FoldM m Word8 x -> FoldM m Word8 x +overSeptets takeLast (FoldM septStep septInit septExtract) = FoldM octStep octInit octExtract where + octInit = Product3 0 0 <$> septInit + octStep (Product3 unconsumedBitsAmount unconsumedOctet septState) octet = + case unconsumedBitsAmount of + 0 -> Product3 1 (unsafeShiftR octet 7) <$> septStep septState (clearBit octet 7) + 6 -> Product3 7 (unsafeShiftR octet 1) <$> septStep septState (unconsumedOctet .|. unsafeShiftR (unsafeShiftL octet 7) 1) + 7 -> Product3 1 (unsafeShiftR octet 7) <$> septStepTwice unconsumedOctet (clearBit octet 7) + _ -> let + bitsToConsume = 7 - unconsumedBitsAmount + newUnconsumedBitsAmount = 8 - bitsToConsume + newUnconsumedOctet = unsafeShiftR octet bitsToConsume + septet = clearBit (unconsumedOctet .|. unsafeShiftL octet unconsumedBitsAmount) 7 + in Product3 newUnconsumedBitsAmount newUnconsumedOctet <$> septStep septState septet + where + septStepTwice septet1 septet2 = do + state1 <- septStep septState septet1 + septStep state1 septet2 + octExtract (Product3 unconsumedBitsAmount unconsumedOctet septState) = + if takeLast && unconsumedBitsAmount == 7 + then septExtract =<< septStep septState unconsumedOctet + else septExtract septState + +sizedByteStringFromOctets :: Int -> FoldM IO Word8 ByteString +sizedByteStringFromOctets size = FoldM step init extract where + init = Product2 0 <$> mallocBytes size + step (Product2 index ptr) octet = do + poke (plusPtr ptr index) octet + return (Product2 (succ index) ptr) + extract (Product2 _ ptr) = do + fp <- newForeignPtr finalizerFree ptr + return (ByteString.PS fp 0 size) + +{-# INLINABLE sizedSeptetPrimArrayFromSeptets #-} +sizedSeptetPrimArrayFromSeptets :: Int -> FoldM IO Word8 (PrimArray Word8) +sizedSeptetPrimArrayFromSeptets septetsAmount = FoldM step init extract where + init = do + let size = div (septetsAmount * 7 + 7) 8 + mpa <- newPrimArray size + return (Product4 mpa 0 0 0) + step (Product4 mpa octetIndex bitIndex unfinishedOctet) inputOctet = + case bitIndex of + 0 -> return (Product4 mpa octetIndex 7 inputOctet) + 1 -> let + finishedOctet = unfinishedOctet .|. unsafeShiftL inputOctet 1 + in do + writePrimArray mpa octetIndex finishedOctet + return (Product4 mpa (succ octetIndex) 0 0) + _ -> let + finishedOctet = unfinishedOctet .|. unsafeShiftL inputOctet bitIndex + newUnfinishedOctet = unsafeShiftR inputOctet (8 - bitIndex) + in do + writePrimArray mpa octetIndex finishedOctet + return (Product4 mpa (succ octetIndex) (pred bitIndex) newUnfinishedOctet) + extract (Product4 mpa octetIndex bitIndex unfinishedOctet) = do + when (bitIndex /= 0) (writePrimArray mpa octetIndex unfinishedOctet) + unsafeFreezePrimArray mpa diff --git a/library/AsciiString/Prelude.hs b/library/AsciiString/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/AsciiString/Prelude.hs @@ -0,0 +1,114 @@ +module AsciiString.Prelude +( + module Exports, + Product2(..), + Product3(..), + Product4(..), + showBits, +) +where + + +-- base +------------------------- +import Control.Applicative as Exports +import Control.Arrow as Exports +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Monad.IO.Class as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.ST as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports +import Data.Functor.Identity as Exports +import Data.Int as Exports +import Data.IORef as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (Last(..), First(..), (<>)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.Semigroup as Exports +import Data.STRef as Exports +import Data.String as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign as Exports hiding (void) +import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) +import GHC.Exts as Exports (lazy, inline, sortWith, groupWith) +import GHC.Generics as Exports (Generic) +import GHC.IO.Exception as Exports +import Numeric as Exports +import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) +import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) +import Text.Printf as Exports (printf, hPrintf) +import Text.Read as Exports (Read(..), readMaybe, readEither) +import Unsafe.Coerce as Exports + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) +import Data.ByteString.Short as Exports (ShortByteString) + +-- primitive +------------------------- +import Data.Primitive.PrimArray as Exports hiding (sizeOf, alignment) + +-- cereal +------------------------- +import Data.Serialize as Exports + +-- foldl +------------------------- +import Control.Foldl as Exports (Fold(..), FoldM(..)) + +-- deferred-folds +------------------------- +import DeferredFolds.Unfold as Exports (Unfold(..)) +import DeferredFolds.UnfoldM as Exports (UnfoldM(..)) + +-- hashable +------------------------- +import Data.Hashable as Exports + + +data Product2 a b = Product2 !a !b + +data Product3 a b c = Product3 !a !b !c + +data Product4 a b c d = Product4 !a !b !c !d + +showBits :: forall a. (Integral a, Show a, FiniteBits a) => a -> String +showBits = padL (finiteBitSize (undefined :: a)) '0' . ($ "") . showIntAtBase 2 intToDigit + +padL :: Int -> Char -> String -> String +padL n c s + | length s < n = s ++ replicate (n - length s) c + | otherwise = s diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,49 @@ +module Main where + +import Prelude +import Test.QuickCheck.Instances +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import qualified Test.QuickCheck as QuickCheck +import qualified Test.QuickCheck.Property as QuickCheck +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Short as ShortByteString +import qualified Data.Serialize as Serialize +import qualified AsciiString + + +main = + defaultMain $ + testGroup "All" $ let + listGen = do + length <- QuickCheck.choose (0, 100) + replicateM length (QuickCheck.choose (0, 127)) + stringGen = fmap chr <$> listGen + byteStringGen = ByteString.pack <$> listGen + shortByteStringGen = ShortByteString.pack <$> listGen + asciiStringGen = AsciiString.fromSeptetList <$> listGen + in + [ + testCase "Reduces the length" $ do + assertEqual "" 6 (AsciiString.length (AsciiString.fromByteString "123456")) + assertEqual "" 7 (AsciiString.length (AsciiString.fromByteString "1234567")) + assertEqual "" 8 (AsciiString.length (AsciiString.fromByteString "12345678")) + assertEqual "" 14 (AsciiString.length (AsciiString.fromByteString "12345678901234")) + , + testProperty "List roundtrip" $ forAll listGen $ \ list -> + list === AsciiString.toSeptetList (AsciiString.fromSeptetList list) + , + testProperty "ByteString Roundtrip" $ forAll byteStringGen $ \ byteString -> + byteString === AsciiString.toByteString (AsciiString.fromByteString byteString) + , + testProperty "ShortByteString Roundtrip" $ forAll shortByteStringGen $ \ sbs -> + sbs === AsciiString.toShortByteString (AsciiString.fromShortByteString sbs) + , + testProperty "String Roundtrip" $ forAll stringGen $ \ string -> + show string === show (fromString string :: AsciiString.AsciiString) + , + testProperty "Cereal Roundtrip" $ forAll asciiStringGen $ \ asciiString -> + Right asciiString === Serialize.decode (Serialize.encode asciiString) + ]