InternedData (empty) → 0.0.0.1
raw patch · 9 files changed
+478/−0 lines, 9 filesdep +InternedDatadep +QuickCheckdep +aesonsetup-changed
Dependencies added: InternedData, QuickCheck, aeson, base, bimaps, binary, bytestring, cereal, cereal-text, compact, containers, criterion, deepseq, hashable, string-conversions, tasty, tasty-quickcheck, tasty-th, text, text-binary, utf8-string, vector-th-unbox
Files
- Data/ByteString/Interned.hs +123/−0
- Data/ByteString/Interned/Internal.hs +75/−0
- InternedData.cabal +128/−0
- LICENSE +30/−0
- README.md +14/−0
- Setup.hs +2/−0
- changelog.md +5/−0
- tests/BenchmarkBuilder.hs +49/−0
- tests/properties.hs +52/−0
+ Data/ByteString/Interned.hs view
@@ -0,0 +1,123 @@++-- | An implementation of @Int@-mapped @ByteString@s with internalization.+-- Wrap a @ByteString@ with 'ibs' to receive a @IBS@. This internalizes the+-- given @ByteString@, meaning that two bytestring inputs @x@ and @y@ will+-- yield the same @IBS@ if they have the same bytestring representation.+--+-- For convenience, conversion from and to text is possible as well and+-- uses @UTF8@ encoding.+--+-- Since internalized @ByteString@ values are never released, be sure to+-- use it sparingly. I.e. to internalize words, not full sentences.+--+-- NOTE Currently, we use a @ByteString@ internally and can not @compact@+-- the structure. The code remains, though as comments in case we switch to+-- another structure.++module Data.ByteString.Interned+ ( module Data.ByteString.Interned+ ) where++import Control.Applicative+import Control.DeepSeq (NFData(..))+import Data.Aeson as A+import Data.Binary as DB+import Data.ByteString (ByteString)+import Data.Hashable+import Data.Serialize as DS+import Data.Serialize.Text+import Data.String as IS+import Data.String.Conversions+import Data.Text.Binary+import Data.Text.Encoding (decodeUtf8,encodeUtf8)+import Data.Text (Text)+import Data.Vector.Unboxed.Deriving+import GHC.Generics++import Data.ByteString.Interned.Internal++++-- | An @IBS@ behaves much like a @ByteString@, but is represented as an+-- @Int@ internally. Its phantom type is polykinded, since we might want to+-- use type-level strings to name things.++newtype IBS k = IBS { getIBS :: Int }+ deriving (Eq,Generic)++derivingUnbox "IBS"+ [t| forall k . IBS k → Int |]+ [| getIBS |]+ [| IBS |]++instance Ord (IBS k) where+ IBS l `compare` IBS r = ibsBimapLookupInt l `compare` ibsBimapLookupInt r+ {-# Inline compare #-}++ibs ∷ ByteString → IBS k+ibs s = IBS $! ibsBimapAdd s+{-# Inline ibs #-}++-- | Handy wrapper to internalize a @Text@ and get a 'IBS'.++ibsText ∷ Text → IBS k+ibsText s = IBS $! ibsBimapAdd $ encodeUtf8 s+{-# Inline ibsText #-}++instance IsString (IBS k) where+ fromString = ibsText . IS.fromString+ {-# Inline fromString #-}++instance Show (IBS k) where+ showsPrec p i r = showsPrec p (ibsTo i :: String) r+ {-# Inline showsPrec #-}++instance Read (IBS k) where+ readsPrec p str = [ (ibsText $ IS.fromString s, y) | (s,y) <- readsPrec p str ]+ {-# Inline readsPrec #-}++instance Hashable (IBS k)++-- | Convert into an @IBS@, using a @Text@ intermediate for proper UTF8+-- conversion.++ibsFrom ∷ ConvertibleStrings x Text ⇒ x → IBS k+ibsFrom = ibsText . convertString+{-# Inline ibsFrom #-}++ibsTo ∷ ConvertibleStrings Text x ⇒ IBS k → x+ibsTo = convertString . ibsToText+{-# Inline ibsTo #-}++ibsToText ∷ IBS k → Text+ibsToText = decodeUtf8 . ibsToUtf8+{-# Inline ibsToText #-}++ibsToUtf8 ∷ IBS k → ByteString+ibsToUtf8 = ibsBimapLookupInt . getIBS+{-# Inline ibsToUtf8 #-}++instance NFData (IBS k) where+ rnf = rnf . getIBS+ {-# Inline rnf #-}++instance Binary (IBS k) where+ put = DB.put . ibsToText+ get = ibs <$> DB.get+ {-# Inline put #-}+ {-# Inline get #-}++instance Serialize (IBS k) where+ put = DS.put . ibsToText+ get = ibs <$> DS.get+ {-# Inline put #-}+ {-# Inline get #-}++instance FromJSON (IBS k) where+ parseJSON s = ibsText <$> parseJSON s+ {-# Inline parseJSON #-}++instance ToJSON (IBS k) where+ toJSON = toJSON . ibsToText+ {-# Inline toJSON #-}+
+ Data/ByteString/Interned/Internal.hs view
@@ -0,0 +1,75 @@++-- | This module keeps a persistent @bimap@ between @ByteString@s and+-- @Int@s.++module Data.ByteString.Interned.Internal where++import Data.ByteString (ByteString)+import Data.IORef (newIORef,IORef,readIORef,atomicWriteIORef,atomicModifyIORef')+import System.IO.Unsafe (unsafePerformIO,unsafeDupablePerformIO)++-- #if __GLASGOW_HASKELL__ >= 821+-- #if MIN_VERSION_base (4,10,0)+-- import Data.Compact+-- #endif++import Data.Bijection.HashMap+import Data.Bijection.Vector++++-- In case we have a modern-enough GHC, all interning happens within+-- a compact region.++-- #if MIN_VERSION_base (4,10,0)+-- type InternedBimap = Compact (Bimap (HashMap ByteString Int) (Vector ByteString))+-- #else+type InternedBimap = Bimap (HashMap ByteString Int) (Vector ByteString)+-- #endif++ibsBimap ∷ IORef InternedBimap+-- #if MIN_VERSION_base (4,10,0)+-- ibsBimap = unsafePerformIO $ newIORef =<< compact empty+-- #else+ibsBimap = unsafePerformIO $ newIORef empty+-- #endif+{-# NoInline ibsBimap #-}++-- | Add @UTF8 ByteString@ and return @Int@ key. Will return key for+-- existing string and thereby serves for lookup in left-to-right+-- direction.++ibsBimapAdd ∷ ByteString → Int+-- #if MIN_VERSION_base (4,10,0)+-- ibsBimapAdd !k = seq k . unsafeDupablePerformIO . atomicModifyIORef' ibsBimap $ updateCompact+-- where+-- updateCompact ∷ InternedBimap → (InternedBimap, Int)+-- updateCompact cmpct = unsafeDupablePerformIO $ do+-- let m = getCompact cmpct+-- case lookupL m k of+-- Just i → return (cmpct, i)+-- Nothing → let s = size m+-- in (,s) <$> compact (insert m (k,s))+-- #else+ibsBimapAdd k = seq k . unsafeDupablePerformIO . atomicModifyIORef' ibsBimap $ go+ where+ go m = case lookupL m k of+ Just i -> (m,i)+ Nothing -> let s = size m+ in (insert m (k,s) , s)+-- #endif+{-# Inline ibsBimapAdd #-}++-- | Lookup based on an @Int@ key. Unsafe totality assumption.++ibsBimapLookupInt ∷ Int → ByteString+ibsBimapLookupInt r = seq r . unsafeDupablePerformIO $ go <$> readIORef ibsBimap+-- #if MIN_VERSION_base (4,10,0)+-- where go cmpct = case lookupR (getCompact cmpct) r of+-- #else+ where go m = case (m `seq` lookupR m r) of+-- #endif+ Just l -> l+ Nothing -> error "btiBimapLookupInt: totality assumption invalidated"+{-# Inline ibsBimapLookupInt #-}+
+ InternedData.cabal view
@@ -0,0 +1,128 @@+name: InternedData+version: 0.0.0.1+author: Christian Hoener zu Siederdissen, 2017-2019+copyright: Christian Hoener zu Siederdissen, 2017-2019+homepage: https://github.com/choener/InternedData+bug-reports: https://github.com/choener/InternedData/issues+maintainer: choener@bioinf.uni-leipzig.de+category: Data, Data Structures, Natural Language Processing+license: BSD3+license-file: LICENSE+build-type: Simple+stability: experimental+cabal-version: >= 1.10.0+tested-with: GHC == 8.6.4+synopsis: Data interning (with compact regions where possible)+description:+ Interned (UTF8) @ByteString@s where the interned structure is+ held in a compact region, if possible.+ .+ - @Data.ByteString.Intern@ does *not* use compact regions++++Extra-Source-Files:+ README.md+ changelog.md++++library+ build-depends: base >= 4.7 && < 5.0+ , aeson >= 0.8+ , binary >= 0.7+ , bytestring >= 0.10.4+ , cereal >= 0.4+ , cereal-text >= 0.1+ , deepseq >= 1.3+ , hashable >= 1.2+ , string-conversions >= 0.4+ , text >= 1.2+ , text-binary >= 0.1+ , utf8-string >= 1.0+ , vector-th-unbox >= 0.2+ --+ , bimaps == 0.1.0.*+ if impl(ghc >= 8.2.0)+ build-depends: compact >= 0.1.0.1+ exposed-modules:+ Data.ByteString.Interned+ Data.ByteString.Interned.Internal++ default-extensions: BangPatterns+ , CPP+ , DataKinds+ , DeriveGeneric+ , FlexibleContexts+ , MultiParamTypeClasses+ , PolyKinds+ , RankNTypes+ , TemplateHaskell+ , TupleSections+ , TypeFamilies+ , UnicodeSyntax+ default-language:+ Haskell2010++ ghc-options:+ -O2 -funbox-strict-fields++++test-suite properties+ type:+ exitcode-stdio-1.0+ main-is:+ properties.hs+ ghc-options:+ -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs:+ tests+ default-language:+ Haskell2010+ default-extensions: BangPatterns+ , ScopedTypeVariables+ , TemplateHaskell+ build-depends: base+ , aeson+ , binary+ , cereal+ , QuickCheck+ , string-conversions+ , tasty >= 0.11+ , tasty-quickcheck >= 0.8+ , tasty-th >= 0.1+ --+ , InternedData++++benchmark BenchmarkBuilder+ build-depends: base+ , bytestring+ , containers+ , criterion >= 1.0.2+ , deepseq+ , text+ --+ , InternedData+ hs-source-dirs:+ tests+ main-is:+ BenchmarkBuilder.hs+ type:+ exitcode-stdio-1.0+ default-language:+ Haskell2010+ default-extensions: BangPatterns+ , ScopedTypeVariables+ ghc-options:+ -O2+ -rtsopts++++source-repository head+ type: git+ location: git://github.com/choener/InternedData+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Christian Hoener zu Siederdissen 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Christian Hoener zu Siederdissen nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,14 @@+[](https://travis-ci.org/choener/InternedData)++# InternedData++- Data.ByteString.Interned provides interned bytestrings via IBS. Some+ convenience functions for utf8 encoding are given as well.++#### Contact++Christian Hoener zu Siederdissen +Leipzig University, Leipzig, Germany +choener@bioinf.uni-leipzig.de +http://www.bioinf.uni-leipzig.de/~choener/ +
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,5 @@+0.0.0.1+-------++- split off from LinguisticsTypes+
+ tests/BenchmarkBuilder.hs view
@@ -0,0 +1,49 @@++module Main where++import Criterion.Main+import Data.Monoid+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB++++tText = T.pack "Small"+{-# NoInline tText #-}++tBS = BC.pack "Small"+{-# NoInline tBS #-}++buildText :: Int -> TLB.Builder+buildText = go+ where go 0 = mempty+ go k = TLB.fromText tText <> go (k-1)+{-# NoInline buildText #-}++buildBS :: Int -> BB.Builder+buildBS = go+ where go 0 = mempty+ go k = BB.byteString tBS <> go (k-1)++++main :: IO ()+main = defaultMain+ [ bgroup "10"+ [ bench "text" $ whnf (TL.length . TLB.toLazyText . buildText) 10+ , bench "bs " $ whnf (BL.length . BB.toLazyByteString . buildBS) 10+ ]+ , bgroup "100"+ [ bench "text" $ whnf (TL.length . TLB.toLazyText . buildText) 100+ , bench "bs " $ whnf (BL.length . BB.toLazyByteString . buildBS) 100+ ]+ , bgroup "1000"+ [ bench "text" $ whnf (TL.length . TLB.toLazyText . buildText) 1000+ , bench "bs " $ whnf (BL.length . BB.toLazyByteString . buildBS) 1000+ ]+ ]+
+ tests/properties.hs view
@@ -0,0 +1,52 @@++module Main where++import Data.String.Conversions+import Debug.Trace+import qualified Data.Aeson as A+import qualified Data.Binary as B+import qualified Data.Serialize as S+import Test.Tasty.QuickCheck+import Test.Tasty.TH++import Data.ByteString.Interned++++-- * IBS (TODO move to LinguisticsTypes)++prop_InternTwice (t :: String) = getIBS x == getIBS y+ where x = ibsText $ cs t+ y = ibsText $ cs t++-- basic property of interning++prop_IBS (t :: String)+ | t == u = True+ | otherwise = traceShow (t, getIBS i, u) False+ where i :: IBS () = ibsFrom t+ u = ibsTo i++-- binary++prop_Binary (t :: String) = t == ibsTo j+ where i :: IBS () = ibsFrom t+ j :: IBS () = B.decode $ B.encode i++-- cereal++prop_Serialize (t :: String) = Right t == (ibsTo <$> j)+ where i :: (IBS ()) = ibsFrom t+ j :: Either String (IBS ()) = S.decode $ S.encode i++-- aeson (more complicated to due the json format!++prop_Aeson (t :: String) = Just [t] == (map ibsTo <$> j)+ where i :: [IBS ()] = [ibsFrom t]+ j :: Maybe [IBS ()] = A.decode $ A.encode i++++main :: IO ()+main = $(defaultMainGenerator)+