diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Christian Hoener zu Siederdissen 2015 + +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. diff --git a/Linguistics/Types.hs b/Linguistics/Types.hs new file mode 100644 --- /dev/null +++ b/Linguistics/Types.hs @@ -0,0 +1,66 @@ + +-- | Assorted types used in linguistics. + +module Linguistics.Types where + +import Data.Text (Text) +import GHC.Generics (Generic) +import Data.Serialize (Serialize) +import Data.Binary (Binary) +import Data.Aeson (FromJSON,ToJSON) +import Data.Serialize.Text () + + + +-- * Connectivity with @LingPy@. +-- +-- + + + +-- | Concept +-- +-- TODO ??? + +newtype Concept = Concept { getConcept :: Text } + deriving (Eq,Ord,Generic) + +instance Binary Concept +instance Serialize Concept +instance FromJSON Concept +instance ToJSON Concept + +-- | +-- +-- TODO ??? + +newtype Counterpart = Counterpart { getCountpart :: Text } + deriving (Eq,Ord,Generic) + +instance Binary Counterpart +instance Serialize Counterpart +instance FromJSON Counterpart +instance ToJSON Counterpart + +-- | A word in phonetic @IPA@ notation. + +newtype IPA = IPA { getIPA :: Text } + deriving (Eq,Ord,Generic) + +instance Binary IPA +instance Serialize IPA +instance FromJSON IPA +instance ToJSON IPA + +-- | +-- +-- TODO ??? + +newtype Doculect = Doculect { getDoculect :: Text } + deriving (Eq,Ord,Generic) + +instance Binary Doculect +instance Serialize Doculect +instance FromJSON Doculect +instance ToJSON Doculect + diff --git a/LinguisticsTypes.cabal b/LinguisticsTypes.cabal new file mode 100644 --- /dev/null +++ b/LinguisticsTypes.cabal @@ -0,0 +1,94 @@ +name: LinguisticsTypes +version: 0.0.0.2 +author: Christian Hoener zu Siederdissen, 2015 +copyright: Christian Hoener zu Siederdissen, 2015 +homepage: https://github.com/choener/LinguisticsTypes +bug-reports: https://github.com/choener/LinguisticsTypes/issues +maintainer: choener@bioinf.uni-leipzig.de +category: Natural Language Processing +license: BSD3 +license-file: LICENSE +build-type: Simple +stability: experimental +cabal-version: >= 1.10.0 +tested-with: GHC == 7.8.4, GHC == 7.10.2 +synopsis: Collection of types for natural language +description: + Types used for natural language applications. Includes an + internalized text type, @BTI@ which represents internalized + @Text@ values with @Int@s. + + + +Extra-Source-Files: + README.md + changelog.md + + + +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 + exposed-modules: + Linguistics.Types + NLP.Text.BTI + NLP.Text.BTI.Internal + + default-extensions: BangPatterns + , DeriveGeneric + , MultiParamTypeClasses + , TemplateHaskell + , TypeFamilies + 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 + , LinguisticsTypes + , QuickCheck + , stringable + , test-framework >= 0.8 && < 0.9 + , test-framework-quickcheck2 >= 0.3 && < 0.4 + , test-framework-th >= 0.2 && < 0.3 + + + +source-repository head + type: git + location: git://github.com/choener/LinguisticsTypes + diff --git a/NLP/Text/BTI.hs b/NLP/Text/BTI.hs new file mode 100644 --- /dev/null +++ b/NLP/Text/BTI.hs @@ -0,0 +1,100 @@ + +-- | An implementation of @Int@-mapped @Text@s with internalization. Wrap +-- a @Text@ with 'bti' to receive a @BTI@. This internalizes the given +-- @Text@, meaning that two text inputs @x@ and @y@ will yield the same +-- @BTI@ if they have the same textual representation. +-- +-- 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 + +import Control.Applicative +import Control.DeepSeq (NFData(..)) +import Data.Aeson as A +import Data.Binary as DB +import Data.Hashable +import Data.Serialize as DS +import Data.Serialize.Text +import Data.Stringable as SA +import Data.String as IS +import Data.Text.Binary +import Data.Text (Text) +import Data.Vector.Unboxed.Deriving +import GHC.Generics + +import NLP.Text.BTI.Internal + + + +-- | A @BTI@ behaves much like a @Text@, but is represented as an @Int@ +-- internally. + +newtype BTI = BTI { getBTI :: Int } + deriving (Eq,Generic) + +derivingUnbox "BTI" + [t| BTI -> Int |] + [| getBTI |] + [| BTI |] + +instance Ord BTI where + BTI l `compare` BTI r = btiBimapLookupInt l `compare` btiBimapLookupInt r + {-# Inline compare #-} + +-- | Handy wrapper to internalize a @Text@ and get a 'BTI'. + +bti :: Text -> BTI +bti s = BTI $! btiBimapAdd s +{-# Inline bti #-} + +instance IsString BTI where + fromString = bti . IS.fromString + {-# Inline fromString #-} + +instance Show BTI where + showsPrec p i r = showsPrec p (toString i) r + {-# Inline showsPrec #-} + +instance Read BTI where + readsPrec p str = [ (bti $ IS.fromString s, y) | (s,y) <- readsPrec p str ] + {-# Inline readsPrec #-} + +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 #-} + +instance NFData BTI where + rnf = rnf . getBTI + {-# Inline rnf #-} + +instance Binary BTI where + put = DB.put . toText + get = fromText <$> DB.get + {-# Inline put #-} + {-# Inline get #-} + +instance Serialize BTI where + put = DS.put . toText + get = fromText <$> DS.get + {-# Inline put #-} + {-# Inline get #-} + +instance FromJSON BTI where + parseJSON s = fromText <$> parseJSON s + {-# Inline parseJSON #-} + +instance ToJSON BTI where + toJSON = toJSON . toText + {-# Inline toJSON #-} + diff --git a/NLP/Text/BTI/Internal.hs b/NLP/Text/BTI/Internal.hs new file mode 100644 --- /dev/null +++ b/NLP/Text/BTI/Internal.hs @@ -0,0 +1,41 @@ + +-- | 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) + +module NLP.Text.BTI.Internal where + +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) + + + +btiBimap :: IORef (Bimap Text Int) +btiBimap = unsafePerformIO $ newIORef empty +{-# NoInline btiBimap #-} + +-- | Add @Text@ 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 -> + case lookupL m k of Just i -> (m,i) + Nothing -> let s = size m + in (insert m (k,s) , s) +{-# Inline btiBimapAdd #-} + +-- | 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" +{-# Inline btiBimapLookupInt #-} + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +[![Build Status](https://travis-ci.org/choener/LinguisticsTypes.svg?branch=master)](https://travis-ci.org/choener/LinguisticsTypes) + +# 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: + + +The BTI module provides an internalized Text type to speed up algorithms on +short strings. This includes word and text alignments. BTI values can be +unboxed. + +#### Contact + +Christian Hoener zu Siederdissen +Leipzig University, Leipzig, Germany +choener@bioinf.uni-leipzig.de +http://www.bioinf.uni-leipzig.de/~choener/ + 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/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,13 @@ +0.0.0.2 +------- + +- added serialization property tests for BTI + +0.0.0.1 +------- + +- common types for natural language / linguistics applications +- includes (moved from NaturalLanguageAlphabets) an internalized Text type +- travis-ci integration +- empty property testing + diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -0,0 +1,52 @@ + +module Main where + +import Data.Stringable +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 NLP.Text.BTI + + + +-- * BTI (TODO move to LinguisticsTypes) + +prop_InternTwice (t :: String) = getBTI x == getBTI y + where x = bti $ fromString t + y = bti $ fromString 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 + +-- binary + +prop_Binary (t :: String) = t == toString j + where i :: BTI = fromString t + j :: BTI = B.decode $ B.encode i + +-- cereal + +prop_Serialize (t :: String) = Right t == (toString <$> j) + where i :: BTI = fromString 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] + j :: Maybe [BTI] = A.decode $ A.encode i + + + +main :: IO () +main = $(defaultMainGenerator) +