diff --git a/LinguisticsTypes.cabal b/LinguisticsTypes.cabal --- a/LinguisticsTypes.cabal +++ b/LinguisticsTypes.cabal @@ -1,7 +1,7 @@ name: LinguisticsTypes -version: 0.0.0.2 -author: Christian Hoener zu Siederdissen, 2015 -copyright: Christian Hoener zu Siederdissen, 2015 +version: 0.0.0.3 +author: Christian Hoener zu Siederdissen, 2015-2017 +copyright: Christian Hoener zu Siederdissen, 2015-2017 homepage: https://github.com/choener/LinguisticsTypes bug-reports: https://github.com/choener/LinguisticsTypes/issues maintainer: choener@bioinf.uni-leipzig.de @@ -11,7 +11,7 @@ build-type: Simple stability: experimental cabal-version: >= 1.10.0 -tested-with: GHC == 7.8.4, GHC == 7.10.2 +tested-with: GHC == 7.10.3, GHC == 8.0.1 synopsis: Collection of types for natural language description: Types used for natural language applications. Includes an @@ -27,22 +27,24 @@ library - build-depends: base >= 4.7 && < 4.9 - , aeson >= 0.8 && < 0.11 - , bimaps >= 0.0.0.4 && < 0.0.1 - , binary >= 0.7 && < 0.8 - , bytestring >= 0.10.4 && < 0.11 - , cereal >= 0.4 && < 0.5 - , cereal-text >= 0.1 && < 0.2 - , deepseq >= 1.3 && < 1.5 - , hashable >= 1.2 && < 1.3 - , intern >= 0.9 && < 0.10 - , log-domain >= 0.10 && < 0.11 - , QuickCheck >= 2.7 && < 2.9 - , stringable >= 0.1.2 && < 0.2 - , text >= 1.2 && < 1.3 - , text-binary >= 0.1 && < 0.3 - , vector-th-unbox >= 0.2 && < 0.3 + 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 + , intern >= 0.9 + , log-domain >= 0.10 + , QuickCheck >= 2.7 + , string-conversions >= 0.4 + , text >= 1.2 + , text-binary >= 0.1 + , utf8-string >= 1.0 + , vector-th-unbox >= 0.2 + -- + , bimaps == 0.1.0.* exposed-modules: Linguistics.Types NLP.Text.BTI @@ -50,6 +52,7 @@ default-extensions: BangPatterns , DeriveGeneric + , FlexibleContexts , MultiParamTypeClasses , TemplateHaskell , TypeFamilies @@ -79,12 +82,38 @@ , aeson , binary , cereal - , LinguisticsTypes , QuickCheck - , stringable - , test-framework >= 0.8 && < 0.9 - , test-framework-quickcheck2 >= 0.3 && < 0.4 - , test-framework-th >= 0.2 && < 0.3 + , string-conversions + , tasty >= 0.11 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 + -- + , LinguisticsTypes + + + +benchmark BenchmarkBuilder + build-depends: base + , bytestring + , containers + , criterion >= 1.0.2 + , deepseq + , text + -- + , LinguisticsTypes + hs-source-dirs: + tests + main-is: + BenchmarkBuilder.hs + type: + exitcode-stdio-1.0 + default-language: + Haskell2010 + default-extensions: BangPatterns + , ScopedTypeVariables + ghc-options: + -O2 + -rtsopts diff --git a/NLP/Text/BTI.hs b/NLP/Text/BTI.hs --- a/NLP/Text/BTI.hs +++ b/NLP/Text/BTI.hs @@ -7,18 +7,22 @@ -- Since internalized @Text@ values are never released, be sure to use it -- sparingly. I.e. to internalize words, not full sentences. -module NLP.Text.BTI where +module NLP.Text.BTI + ( module NLP.Text.BTI + ) 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.Stringable as SA 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 @@ -45,7 +49,7 @@ -- | Handy wrapper to internalize a @Text@ and get a 'BTI'. bti :: Text -> BTI -bti s = BTI $! btiBimapAdd s +bti s = BTI $! btiBimapAdd $ encodeUtf8 s {-# Inline bti #-} instance IsString BTI where @@ -53,7 +57,7 @@ {-# Inline fromString #-} instance Show BTI where - showsPrec p i r = showsPrec p (toString i) r + showsPrec p i r = showsPrec p (btiToCS i :: String) r {-# Inline showsPrec #-} instance Read BTI where @@ -62,39 +66,39 @@ instance Hashable BTI -instance Stringable BTI where - toString = toString . btiBimapLookupInt . getBTI - fromString = bti . SA.fromString - length = SA.length . btiBimapLookupInt . getBTI - toText = toText . btiBimapLookupInt . getBTI - fromText = bti . fromText - {-# Inline toString #-} - {-# Inline fromString #-} - {-# Inline length #-} - {-# Inline toText #-} - {-# Inline fromText #-} +btiFromCS :: ConvertibleStrings x Text => x -> BTI +btiFromCS = bti . convertString +btiToCS :: ConvertibleStrings Text x => BTI -> x +btiToCS = convertString . btiToText + +btiToText :: BTI -> Text +btiToText = decodeUtf8 . btiToUtf8 + +btiToUtf8 :: BTI -> ByteString +btiToUtf8 = btiBimapLookupInt . getBTI + instance NFData BTI where rnf = rnf . getBTI {-# Inline rnf #-} instance Binary BTI where - put = DB.put . toText - get = fromText <$> DB.get + put = DB.put . btiToText + get = bti <$> DB.get {-# Inline put #-} {-# Inline get #-} instance Serialize BTI where - put = DS.put . toText - get = fromText <$> DS.get + put = DS.put . btiToText + get = bti <$> DS.get {-# Inline put #-} {-# Inline get #-} instance FromJSON BTI where - parseJSON s = fromText <$> parseJSON s + parseJSON s = bti <$> parseJSON s {-# Inline parseJSON #-} instance ToJSON BTI where - toJSON = toJSON . toText + toJSON = toJSON . btiToText {-# Inline toJSON #-} diff --git a/NLP/Text/BTI/Internal.hs b/NLP/Text/BTI/Internal.hs --- a/NLP/Text/BTI/Internal.hs +++ b/NLP/Text/BTI/Internal.hs @@ -1,30 +1,27 @@ --- | This module keeps a persistent @bimap@ between @Text@s and @Int@s --- --- TODO make this a bimap @Text <-> Vector@. Compare performance when --- printing backtracking results. (Do this after the Builder-based --- backtracking is online) +-- | This module keeps a persistent @bimap@ between @Text@s and @Int@s. module NLP.Text.BTI.Internal where +import Data.ByteString.UTF8 import Data.IORef (newIORef,IORef,readIORef,atomicWriteIORef,atomicModifyIORef') -import Data.Text (Text) import System.IO.Unsafe (unsafePerformIO,unsafeDupablePerformIO) -import Data.Bijection.Hash (Bimap,empty,lookupL,lookupR,size,insert) +import Data.Bijection.HashMap +import Data.Bijection.Vector -btiBimap :: IORef (Bimap Text Int) +btiBimap :: IORef (Bimap (HashMap ByteString Int) (Vector ByteString)) btiBimap = unsafePerformIO $ newIORef empty {-# NoInline btiBimap #-} --- | Add @Text@ and return @Int@ key. Will return key for +-- | Add @UTF8 ByteString@ and return @Int@ key. Will return key for -- existing string and thereby serves for lookup in left-to-right -- direction. -btiBimapAdd :: Text -> Int -btiBimapAdd k = unsafeDupablePerformIO $ atomicModifyIORef' btiBimap $ \m -> +btiBimapAdd :: ByteString -> Int +btiBimapAdd k = seq k .unsafeDupablePerformIO . atomicModifyIORef' btiBimap $ \m -> case lookupL m k of Just i -> (m,i) Nothing -> let s = size m in (insert m (k,s) , s) @@ -33,9 +30,10 @@ -- | Lookup the @InternedMultiChar@ based on an @Int@ key. Unsafe totality -- assumption. -btiBimapLookupInt :: Int -> Text -btiBimapLookupInt r = seq r . unsafeDupablePerformIO $ atomicModifyIORef' btiBimap $ \m -> - case lookupR m r of Just l -> (m,l) - Nothing -> error "btiBimapLookupInt: totality assumption invalidated" +btiBimapLookupInt :: Int -> ByteString +btiBimapLookupInt r = seq r . unsafeDupablePerformIO $ go <$> readIORef btiBimap + where go m = case (m `seq` lookupR m r) of + Just l -> l + Nothing -> error "btiBimapLookupInt: totality assumption invalidated" {-# Inline btiBimapLookupInt #-} diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,9 +2,9 @@ # LinguisticsTypes -Here we collect assorted types and basic operations on those. We also provide -some connectivity with other approaches in different languages. To this end, -newtypes for types in LingPy are available: +Here we collect assorted types for linguistics and basic operations on those. +We also provide some connectivity with other approaches in different languages. +To this end, newtypes for types in LingPy are available: The BTI module provides an internalized Text type to speed up algorithms on diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +0.0.0.3 +------- + +- uses heterogeneous bimaps now +- removed upper bounds + 0.0.0.2 ------- diff --git a/tests/BenchmarkBuilder.hs b/tests/BenchmarkBuilder.hs new file mode 100644 --- /dev/null +++ b/tests/BenchmarkBuilder.hs @@ -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 + ] + ] + diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -1,13 +1,13 @@ module Main where -import Data.Stringable +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.Framework.Providers.QuickCheck2 -import Test.Framework.TH +import Test.Tasty.QuickCheck +import Test.Tasty.TH import NLP.Text.BTI @@ -16,33 +16,33 @@ -- * BTI (TODO move to LinguisticsTypes) prop_InternTwice (t :: String) = getBTI x == getBTI y - where x = bti $ fromString t - y = bti $ fromString t + where x = bti $ cs t + y = bti $ cs t -- basic property of interning prop_BTI (t :: String) | t == u = True | otherwise = traceShow (t, getBTI i, u) False - where i :: BTI = fromString t - u = toString i + where i :: BTI = btiFromCS t + u = btiToCS i -- binary -prop_Binary (t :: String) = t == toString j - where i :: BTI = fromString t +prop_Binary (t :: String) = t == btiToCS j + where i :: BTI = btiFromCS t j :: BTI = B.decode $ B.encode i -- cereal -prop_Serialize (t :: String) = Right t == (toString <$> j) - where i :: BTI = fromString t +prop_Serialize (t :: String) = Right t == (btiToCS <$> j) + where i :: BTI = btiFromCS t j :: Either String BTI = S.decode $ S.encode i -- aeson (more complicated to due the json format! -prop_Aeson (t :: String) = Just [t] == (map toString <$> j) - where i :: [BTI] = [fromString t] +prop_Aeson (t :: String) = Just [t] == (map btiToCS <$> j) + where i :: [BTI] = [btiFromCS t] j :: Maybe [BTI] = A.decode $ A.encode i