diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +## Text Metrics 0.3.3 + +* Slightly optimized the `levenshtein` and `levenshteinNorm` functions. [PR + 50](https://github.com/mrkkrp/text-metrics/pull/50). + +## Text Metrics 0.3.2 + +* Works with `text-2.0`. + +## Text Metrics 0.3.1 + +* Fixed a bug in the implementation of Jaro-Winkler distance when two + strings share a long prefix. [PR + 21](https://github.com/mrkkrp/text-metrics/pull/21). + +* Dropped support for GHC 8.6 and older. + ## Text Metrics 0.3.0 * All functions are now implemented in pure Haskell. diff --git a/Data/Text/Metrics.hs b/Data/Text/Metrics.hs --- a/Data/Text/Metrics.hs +++ b/Data/Text/Metrics.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} + -- | -- Module : Data.Text.Metrics --- Copyright : © 2016–2017 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -15,47 +18,43 @@ -- implementations are written in Haskell while staying almost as fast, see: -- -- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} - module Data.Text.Metrics ( -- * Levenshtein variants - levenshtein - , levenshteinNorm - , damerauLevenshtein - , damerauLevenshteinNorm + levenshtein, + levenshteinNorm, + damerauLevenshtein, + damerauLevenshteinNorm, + -- * Treating inputs like sets - , overlap - , jaccard + overlap, + jaccard, + -- * Other - , hamming - , jaro - , jaroWinkler ) + hamming, + jaro, + jaroWinkler, + ) where import Control.Monad import Control.Monad.ST import Data.Map.Strict (Map) +import Data.Map.Strict qualified as M +import Data.Primitive qualified as P import Data.Ratio import Data.Text +import Data.Text qualified as T +import Data.Text.Internal qualified as T +import Data.Text.Unsafe qualified as TU +import Data.Vector.Unboxed.Mutable qualified as VUM import GHC.Exts (inline) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import qualified Data.Text.Unsafe as TU -import qualified Data.Vector.Unboxed.Mutable as VUM -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - ---------------------------------------------------------------------------- -- Levenshtein variants --- | Return Levenshtein distance between two 'Text' values. Classic +-- | Return the Levenshtein distance between two 'Text' values. The -- Levenshtein distance between two strings is the minimal number of --- operations necessary to transform one string into another. For +-- operations necessary to transform one string into another. For the -- Levenshtein distance allowed operations are: deletion, insertion, and -- substitution. -- @@ -63,11 +62,10 @@ -- -- __Heads up__, before version /0.3.0/ this function returned -- 'Data.Numeric.Natural'. - levenshtein :: Text -> Text -> Int levenshtein a b = fst (levenshtein_ a b) --- | Return normalized Levenshtein distance between two 'Text' values. +-- | Return the normalized Levenshtein distance between two 'Text' values. -- Result is a non-negative rational number (represented as @'Ratio' -- 'Data.Numeric.Natural'@), where 0 signifies no similarity between the -- strings, while 1 means exact match. @@ -76,43 +74,46 @@ -- -- __Heads up__, before version /0.3.0/ this function returned @'Ratio' -- 'Data.Numeric.Natural'@. - levenshteinNorm :: Text -> Text -> Ratio Int levenshteinNorm = norm levenshtein_ --- | An internal helper, returns Levenshtein distance as the first element --- of the tuple and max length of the two inputs as the second element of --- the tuple. - +-- | An internal helper, returns the Levenshtein distance as the first +-- element of the tuple and max length of the two inputs as the second +-- element of the tuple. levenshtein_ :: Text -> Text -> (Int, Int) levenshtein_ a b | T.null a = (lenb, lenm) | T.null b = (lena, lenm) | otherwise = runST $ do let v_len = lenb + 1 - v <- VUM.unsafeNew (v_len * 2) + v <- P.newPrimArray (v_len * 2) let gov !i = when (i < v_len) $ do - VUM.unsafeWrite v i i + P.writePrimArray v i i gov (i + 1) goi !i !na !v0 !v1 = do let !(TU.Iter ai da) = TU.iter a na goj !j !nb = when (j < lenb) $ do let !(TU.Iter bj db) = TU.iter b nb - cost = if ai == bj then 0 else 1 - x <- (+ 1) <$> VUM.unsafeRead v (v1 + j) - y <- (+ 1) <$> VUM.unsafeRead v (v0 + j + 1) - z <- (+ cost) <$> VUM.unsafeRead v (v0 + j) - VUM.unsafeWrite v (v1 + j + 1) (min x (min y z)) - goj (j + 1) (nb + db) + if ai == bj + then do + z <- P.readPrimArray v (v0 + j) + P.writePrimArray v (v1 + j + 1) z + goj (j + 1) (nb + db) + else do + x <- P.readPrimArray v (v1 + j) + y <- P.readPrimArray v (v0 + j + 1) + z <- P.readPrimArray v (v0 + j) + P.writePrimArray v (v1 + j + 1) (1 + (min x (min y z))) + goj (j + 1) (nb + db) when (i < lena) $ do - VUM.unsafeWrite v v1 (i + 1) + P.writePrimArray v v1 (i + 1) goj 0 0 goi (i + 1) (na + da) v1 v0 gov 0 goi 0 0 0 v_len - ld <- VUM.unsafeRead v (lenb + if even lena then 0 else v_len) + ld <- P.readPrimArray v (lenb + if even lena then 0 else v_len) return (ld, lenm) where lena = T.length a @@ -120,7 +121,7 @@ lenm = max lena lenb {-# INLINE levenshtein_ #-} --- | Return Damerau-Levenshtein distance between two 'Text' values. The +-- | Return the Damerau-Levenshtein distance between two 'Text' values. The -- function works like 'levenshtein', but the collection of allowed -- operations also includes transposition of two /adjacent/ characters. -- @@ -128,11 +129,10 @@ -- -- __Heads up__, before version /0.3.0/ this function returned -- 'Data.Numeric.Natural'. - damerauLevenshtein :: Text -> Text -> Int damerauLevenshtein a b = fst (damerauLevenshtein_ a b) --- | Return normalized Damerau-Levenshtein distance between two 'Text' +-- | Return the normalized Damerau-Levenshtein distance between two 'Text' -- values. 0 signifies no similarity between the strings, while 1 means -- exact match. -- @@ -140,14 +140,12 @@ -- -- __Heads up__, before version /0.3.0/ this function returned @'Ratio' -- 'Data.Numeric.Natural'@. - damerauLevenshteinNorm :: Text -> Text -> Ratio Int damerauLevenshteinNorm = norm damerauLevenshtein_ --- | An internal helper, returns Damerau-Levenshtein distance as the first --- element of the tuple and max length of the two inputs as the second +-- | An internal helper, returns the Damerau-Levenshtein distance as the +-- first element of the tuple and max length of the two inputs as the second -- element of the tuple. - damerauLevenshtein_ :: Text -> Text -> (Int, Int) damerauLevenshtein_ a b | T.null a = (lenb, lenm) @@ -192,14 +190,13 @@ ---------------------------------------------------------------------------- -- Treating inputs like sets --- | Return overlap coefficient for two 'Text' values. Returned value is in --- the range from 0 (no similarity) to 1 (exact match). Return 1 if both +-- | Return the overlap coefficient for two 'Text' values. Returned value is +-- in the range from 0 (no similarity) to 1 (exact match). Return 1 if both -- 'Text' values are empty. -- -- See also: . -- -- @since 0.3.0 - overlap :: Text -> Text -> Ratio Int overlap a b = if d == 0 @@ -208,14 +205,13 @@ where d = min (T.length a) (T.length b) --- | Return Jaccard similarity coefficient for two 'Text' values. Returned --- value is in the range from 0 (no similarity) to 1 (exact match). Return 1 --- if both +-- | Return the Jaccard similarity coefficient for two 'Text' values. +-- Returned value is in the range from 0 (no similarity) to 1 (exact match). +-- Return 1 if both -- -- See also: -- -- @since 0.3.0 - jaccard :: Text -> Text -> Ratio Int jaccard a b = if d == 0 @@ -224,11 +220,10 @@ where ma = mkTextMap a mb = mkTextMap b - d = unionSize ma mb + d = unionSize ma mb -- | Make a map from 'Char' to 'Int' representing how many times the 'Char' -- appears in the input 'Text'. - mkTextMap :: Text -> Map Char Int mkTextMap = T.foldl' f M.empty where @@ -236,13 +231,11 @@ {-# INLINE mkTextMap #-} -- | Return intersection size between two 'Text'-maps. - intersectionSize :: Map Char Int -> Map Char Int -> Int intersectionSize a b = M.foldl' (+) 0 (M.intersectionWith min a b) {-# INLINE intersectionSize #-} -- | Return union size between two 'Text'-maps. - unionSize :: Map Char Int -> Map Char Int -> Int unionSize a b = M.foldl' (+) 0 (M.unionWith max a b) {-# INLINE unionSize #-} @@ -250,7 +243,7 @@ ---------------------------------------------------------------------------- -- Other --- | /O(n)/ Return Hamming distance between two 'Text' values. Hamming +-- | /O(n)/ Return the Hamming distance between two 'Text' values. Hamming -- distance is defined as the number of positions at which the corresponding -- symbols are different. The input 'Text' values should be of equal length -- or 'Nothing' will be returned. @@ -259,9 +252,8 @@ -- -- __Heads up__, before version /0.3.0/ this function returned @'Maybe' -- 'Data.Numeric.Natural'@. - hamming :: Text -> Text -> Maybe Int -hamming a b = +hamming a@(T.Text _ _ len) b = if T.length a == T.length b then Just (go 0 0 0) else Nothing @@ -269,13 +261,13 @@ go !na !nb !r = let !(TU.Iter cha da) = TU.iter a na !(TU.Iter chb db) = TU.iter b nb - in if | na == len -> r + in if + | na == len -> r | cha /= chb -> go (na + da) (nb + db) (r + 1) - | otherwise -> go (na + da) (nb + db) r - len = TU.lengthWord16 a + | otherwise -> go (na + da) (nb + db) r --- | Return Jaro distance between two 'Text' values. Returned value is in --- the range from 0 (no similarity) to 1 (exact match). +-- | Return the Jaro distance between two 'Text' values. Returned value is +-- in the range from 0 (no similarity) to 1 (exact match). -- -- While the algorithm is pretty clear for artificial examples (like those -- from the linked Wikipedia article), for /arbitrary/ strings, it may be @@ -296,7 +288,6 @@ -- -- __Heads up__, before version /0.3.0/ this function returned @'Ratio' -- 'Data.Numeric.Natural'@. - jaro :: Text -> Text -> Ratio Int jaro a b = if T.null a || T.null b @@ -326,7 +317,7 @@ tj <- VUM.unsafeRead r 0 if j < tj then VUM.unsafeModify r (+ 1) 2 - else VUM.unsafeWrite r 0 j + else VUM.unsafeWrite r 0 j VUM.unsafeWrite v j 1 VUM.unsafeModify r (+ 1) 1 else goj (j + 1) (nb + db) @@ -339,12 +330,15 @@ return $ if m == 0 then 0 % 1 - else ((m % lena) + - (m % lenb) + - ((m - t) % m)) / 3 + else + ( (m % lena) + + (m % lenb) + + ((m - t) % m) + ) + / 3 --- | Return Jaro-Winkler distance between two 'Text' values. Returned value --- is in range from 0 (no similarity) to 1 (exact match). +-- | Return the Jaro-Winkler distance between two 'Text' values. Returned +-- value is in range from 0 (no similarity) to 1 (exact match). -- -- See also: -- @@ -352,27 +346,17 @@ -- -- __Heads up__, before version /0.3.0/ this function returned @'Ratio' -- 'Data.Numeric.Natural'@. - jaroWinkler :: Text -> Text -> Ratio Int jaroWinkler a b = dj + (1 % 10) * l * (1 - dj) where dj = inline (jaro a b) - l = fromIntegral (commonPrefix a b) - --- | Return length of common prefix two 'Text' values have. + l = fromIntegral (min 4 (commonPrefix a b)) +-- | Return the length of the common prefix two 'Text' values have. commonPrefix :: Text -> Text -> Int -commonPrefix a b = go 0 0 0 - where - go !na !nb !r = - let !(TU.Iter cha da) = TU.iter a na - !(TU.Iter chb db) = TU.iter b nb - in if | na == lena -> r - | nb == lenb -> r - | cha == chb -> go (na + da) (nb + db) (r + 1) - | otherwise -> r - lena = TU.lengthWord16 a - lenb = TU.lengthWord16 b +commonPrefix a b = case T.commonPrefixes a b of + Nothing -> 0 + Just (pref, _, _) -> T.length pref {-# INLINE commonPrefix #-} ---------------------------------------------------------------------------- @@ -381,7 +365,7 @@ norm :: (Text -> Text -> (Int, Int)) -> Text -> Text -> Ratio Int norm f a b = let (r, l) = f a b - in if r == 0 - then 1 % 1 - else 1 % 1 - r % l + in if r == 0 + then 1 % 1 + else 1 % 1 - r % l {-# INLINE norm #-} diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright © 2016–2017 Mark Karpov +Copyright © 2016–present Mark Karpov All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,8 +4,7 @@ [![Hackage](https://img.shields.io/hackage/v/text-metrics.svg?style=flat)](https://hackage.haskell.org/package/text-metrics) [![Stackage Nightly](http://stackage.org/package/text-metrics/badge/nightly)](http://stackage.org/nightly/package/text-metrics) [![Stackage LTS](http://stackage.org/package/text-metrics/badge/lts)](http://stackage.org/lts/package/text-metrics) -[![Build Status](https://travis-ci.org/mrkkrp/text-metrics.svg?branch=master)](https://travis-ci.org/mrkkrp/text-metrics) -[![Coverage Status](https://coveralls.io/repos/mrkkrp/text-metrics/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/text-metrics?branch=master) +![CI](https://github.com/mrkkrp/text-metrics/workflows/CI/badge.svg?branch=master) The library provides efficient implementations of various strings metric algorithms. It works with strict `Text` values. @@ -24,8 +23,9 @@ ## Comparison with the `edit-distance` package -There is [`edit-distance`](https://hackage.haskell.org/package/edit-distance) package whose scope overlaps with the scope of -this package. The differences are: +There is +[`edit-distance`](https://hackage.haskell.org/package/edit-distance) package +whose scope overlaps with the scope of this package. The differences are: * `edit-distance` allows to specify costs for every operation when calculating Levenshtein distance (insertion, deletion, substitution, and @@ -41,10 +41,19 @@ ## Implementation Although we originally used C for speed, currently all functions are pure -Haskell tuned for performance. See [this blog post](https://markkarpov.com/post/migrating-text-metrics.html) for more info. +Haskell tuned for performance. See [this blog +post](https://markkarpov.com/post/migrating-text-metrics.html) for more +info. +## Contribution + +Issues, bugs, and questions may be reported in [the GitHub issue tracker for +this project](https://github.com/mrkkrp/text-metrics/issues). + +Pull requests are also welcome. + ## License -Copyright © 2016–2017 Mark Karpov +Copyright © 2016–present Mark Karpov Distributed under BSD 3 clause license. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/bench-memory/Main.hs b/bench-memory/Main.hs deleted file mode 100644 --- a/bench-memory/Main.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Main (main) where - -import Control.DeepSeq -import Control.Monad -import Data.Text (Text) -import Data.Text.Metrics -import Weigh -import qualified Data.Text as T - -main :: IO () -main = mainWith $ do - setColumns [Case, Allocated, GCs, Max] - bmetric "levenshtein" levenshtein - bmetric "levenshteinNorm" levenshteinNorm - bmetric "damerauLevenshtein" damerauLevenshtein - bmetric "damerauLevenshteinNorm" damerauLevenshteinNorm - bmetric "overlap" overlap - bmetric "jaccard" jaccard - bmetric "hamming" hamming - bmetric "jaro" jaro - bmetric "jaroWinkler" jaroWinkler - --- | Perform a series to measurements with the same metric function. - -bmetric :: NFData a - => String -- ^ Name of the benchmark group - -> (Text -> Text -> a) -- ^ The function to benchmark - -> Weigh () -bmetric name f = forM_ stdSeries $ \n -> - func (name ++ "/" ++ show n) (uncurry f) (testData n, testData n) - --- | The series of lengths to try with every function as part of 'btmetric'. - -stdSeries :: [Int] -stdSeries = [5,10,20,40,80,160] - -testData :: Int -> Text -testData n = T.pack . take n . drop (n `mod` 4) . cycle $ ['a'..'z'] diff --git a/bench-speed/Main.hs b/bench-speed/Main.hs deleted file mode 100644 --- a/bench-speed/Main.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Main (main) where - -import Control.DeepSeq -import Criterion.Main -import Data.Text (Text) -import Data.Text.Metrics -import qualified Data.Text as T - -main :: IO () -main = defaultMain - [ btmetric "levenshtein" levenshtein - , btmetric "levenshteinNorm" levenshteinNorm - , btmetric "damerauLevenshtein" damerauLevenshtein - , btmetric "damerauLevenshteinNorm" damerauLevenshteinNorm - , btmetric "overlap" overlap - , btmetric "jaccard" jaccard - , btmetric "hamming" hamming - , btmetric "jaro" jaro - , btmetric "jaroWinkler" jaroWinkler ] - --- | Produce benchmark group to test. - -btmetric :: NFData a => String -> (Text -> Text -> a) -> Benchmark -btmetric name f = bgroup name (bs <$> stdSeries) - where - bs n = env (return (testData n, testData n)) (bench (show n) . nf (uncurry f)) - --- | The series of lengths to try with every function as part of 'btmetric'. - -stdSeries :: [Int] -stdSeries = [5,10,20,40,80,160] - -testData :: Int -> Text -testData n = T.pack . take n . drop (n `mod` 4) . cycle $ ['a'..'z'] diff --git a/bench/memory/Main.hs b/bench/memory/Main.hs new file mode 100644 --- /dev/null +++ b/bench/memory/Main.hs @@ -0,0 +1,39 @@ +module Main (main) where + +import Control.DeepSeq +import Control.Monad +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Metrics +import Weigh + +main :: IO () +main = mainWith $ do + setColumns [Case, Allocated, GCs, Max] + bmetric "levenshtein" levenshtein + bmetric "levenshteinNorm" levenshteinNorm + bmetric "damerauLevenshtein" damerauLevenshtein + bmetric "damerauLevenshteinNorm" damerauLevenshteinNorm + bmetric "overlap" overlap + bmetric "jaccard" jaccard + bmetric "hamming" hamming + bmetric "jaro" jaro + bmetric "jaroWinkler" jaroWinkler + +-- | Perform a series to measurements with the same metric function. +bmetric :: + (NFData a) => + -- | Name of the benchmark group + String -> + -- | The function to benchmark + (Text -> Text -> a) -> + Weigh () +bmetric name f = forM_ stdSeries $ \n -> + func (name ++ "/" ++ show n) (uncurry f) (testData n, testData n) + +-- | The series of lengths to try with every function as part of 'btmetric'. +stdSeries :: [Int] +stdSeries = [5, 10, 20, 40, 80, 160] + +testData :: Int -> Text +testData n = T.pack . take n . drop (n `mod` 4) . cycle $ ['a' .. 'z'] diff --git a/bench/speed/Main.hs b/bench/speed/Main.hs new file mode 100644 --- /dev/null +++ b/bench/speed/Main.hs @@ -0,0 +1,34 @@ +module Main (main) where + +import Control.DeepSeq +import Criterion.Main +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Metrics + +main :: IO () +main = + defaultMain + [ btmetric "levenshtein" levenshtein, + btmetric "levenshteinNorm" levenshteinNorm, + btmetric "damerauLevenshtein" damerauLevenshtein, + btmetric "damerauLevenshteinNorm" damerauLevenshteinNorm, + btmetric "overlap" overlap, + btmetric "jaccard" jaccard, + btmetric "hamming" hamming, + btmetric "jaro" jaro, + btmetric "jaroWinkler" jaroWinkler + ] + +-- | Produce benchmark group to test. +btmetric :: (NFData a) => String -> (Text -> Text -> a) -> Benchmark +btmetric name f = bgroup name (bs <$> stdSeries) + where + bs n = env (return (testData n, testData n)) (bench (show n) . nf (uncurry f)) + +-- | The series of lengths to try with every function as part of 'btmetric'. +stdSeries :: [Int] +stdSeries = [5, 10, 20, 40, 80, 160] + +testData :: Int -> Text +testData n = T.pack . take n . drop (n `mod` 4) . cycle $ ['a' .. 'z'] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,20 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Data.Ratio import Data.Text (Text) +import Data.Text qualified as T import Data.Text.Metrics import Test.Hspec import Test.QuickCheck -import qualified Data.Text as T -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - instance Arbitrary Text where arbitrary = T.pack <$> arbitrary @@ -26,140 +21,129 @@ describe "levenshtein" $ do testSwap levenshtein context "with concrete examples" $ do - testPair levenshtein "kitten" "sitting" 3 - testPair levenshtein "cake" "drake" 2 - testPair levenshtein "saturday" "sunday" 3 - testPair levenshtein "red" "wax" 3 -#if __GLASGOW_HASKELL__ >= 710 - testPair levenshtein "a😀c" "abc" 1 -#endif - testPair levenshtein "lucky" "lucky" 0 - testPair levenshtein "" "" 0 + testPair levenshtein "kitten" "sitting" 3 + testPair levenshtein "cake" "drake" 2 + testPair levenshtein "saturday" "sunday" 3 + testPair levenshtein "red" "wax" 3 + testPair levenshtein "a😀c" "abc" 1 + testPair levenshtein "lucky" "lucky" 0 + testPair levenshtein "" "" 0 describe "levenshteinNorm" $ do testSwap levenshteinNorm - testPair levenshteinNorm "kitten" "sitting" (4 % 7) - testPair levenshteinNorm "cake" "drake" (3 % 5) - testPair levenshteinNorm "saturday" "sunday" (5 % 8) - testPair levenshteinNorm "red" "wax" (0 % 1) -#if __GLASGOW_HASKELL__ >= 710 - testPair levenshteinNorm "a😀c" "abc" (2 % 3) -#endif - testPair levenshteinNorm "lucky" "lucky" (1 % 1) - testPair levenshteinNorm "" "" (1 % 1) + testPair levenshteinNorm "kitten" "sitting" (4 % 7) + testPair levenshteinNorm "cake" "drake" (3 % 5) + testPair levenshteinNorm "saturday" "sunday" (5 % 8) + testPair levenshteinNorm "red" "wax" (0 % 1) + testPair levenshteinNorm "a😀c" "abc" (2 % 3) + testPair levenshteinNorm "lucky" "lucky" (1 % 1) + testPair levenshteinNorm "" "" (1 % 1) describe "damerauLevenshtein" $ do testSwap damerauLevenshtein testPair damerauLevenshtein "veryvery long" "very long" 4 - testPair damerauLevenshtein "thing" "think" 1 - testPair damerauLevenshtein "nose" "ones" 2 - testPair damerauLevenshtein "thing" "sign" 3 - testPair damerauLevenshtein "red" "wax" 3 -#if __GLASGOW_HASKELL__ >= 710 - testPair damerauLevenshtein "a😀c" "abc" 1 -#endif - testPair damerauLevenshtein "lucky" "lucky" 0 - testPair damerauLevenshtein "" "" 0 + testPair damerauLevenshtein "thing" "think" 1 + testPair damerauLevenshtein "nose" "ones" 2 + testPair damerauLevenshtein "thing" "sign" 3 + testPair damerauLevenshtein "red" "wax" 3 + testPair damerauLevenshtein "a😀c" "abc" 1 + testPair damerauLevenshtein "lucky" "lucky" 0 + testPair damerauLevenshtein "" "" 0 describe "damerauLevenshteinNorm" $ do testSwap damerauLevenshteinNorm testPair damerauLevenshteinNorm "veryvery long" "very long" (9 % 13) - testPair damerauLevenshteinNorm "thing" "think" (4 % 5) - testPair damerauLevenshteinNorm "nose" "ones" (1 % 2) - testPair damerauLevenshteinNorm "thing" "sign" (2 % 5) - testPair damerauLevenshteinNorm "red" "wax" (0 % 1) -#if __GLASGOW_HASKELL__ >= 710 - testPair damerauLevenshteinNorm "a😀c" "abc" (2 % 3) -#endif - testPair damerauLevenshteinNorm "lucky" "lucky" (1 % 1) - testPair damerauLevenshteinNorm "" "" (1 % 1) + testPair damerauLevenshteinNorm "thing" "think" (4 % 5) + testPair damerauLevenshteinNorm "nose" "ones" (1 % 2) + testPair damerauLevenshteinNorm "thing" "sign" (2 % 5) + testPair damerauLevenshteinNorm "red" "wax" (0 % 1) + testPair damerauLevenshteinNorm "a😀c" "abc" (2 % 3) + testPair damerauLevenshteinNorm "lucky" "lucky" (1 % 1) + testPair damerauLevenshteinNorm "" "" (1 % 1) describe "hamming" $ do testSwap hamming testPair hamming "karolin" "kathrin" (Just 3) testPair hamming "karolin" "kerstin" (Just 3) testPair hamming "1011101" "1001001" (Just 2) testPair hamming "2173896" "2233796" (Just 3) - testPair hamming "toned" "roses" (Just 3) - testPair hamming "red" "wax" (Just 3) -#if __GLASGOW_HASKELL__ >= 710 - testPair hamming "a😀c" "abc" (Just 1) -#endif - testPair hamming "lucky" "lucky" (Just 0) - testPair hamming "" "" (Just 0) - testPair hamming "small" "big" Nothing + testPair hamming "toned" "roses" (Just 3) + testPair hamming "red" "wax" (Just 3) + testPair hamming "a😀c" "abc" (Just 1) + testPair hamming "lucky" "lucky" (Just 0) + testPair hamming "" "" (Just 0) + testPair hamming "small" "big" Nothing describe "jaro" $ do - testPair jaro "aa" "a" (5 % 6) - testPair jaro "a" "aa" (5 % 6) - testPair jaro "martha" "marhta" (17 % 18) - testPair jaro "marhta" "martha" (17 % 18) - testPair jaro "dwayne" "duane" (37 % 45) - testPair jaro "duane" "dwayne" (37 % 45) - testPair jaro "dixon" "dicksonx" (23 % 30) - testPair jaro "dicksonx" "dixon" (23 % 30) - testPair jaro "jones" "johnson" (83 % 105) - testPair jaro "johnson" "jones" (83 % 105) - testPair jaro "brain" "brian" (14 % 15) - testPair jaro "brian" "brain" (14 % 15) - testPair jaro "five" "ten" (0 % 1) - testPair jaro "ten" "five" (0 % 1) - testPair jaro "lucky" "lucky" (1 % 1) -#if __GLASGOW_HASKELL__ >= 710 - testPair jaro "a😀c" "abc" (7 % 9) -#endif - testPair jaro "" "" (0 % 1) + testPair jaro "aa" "a" (5 % 6) + testPair jaro "a" "aa" (5 % 6) + testPair jaro "martha" "marhta" (17 % 18) + testPair jaro "marhta" "martha" (17 % 18) + testPair jaro "dwayne" "duane" (37 % 45) + testPair jaro "duane" "dwayne" (37 % 45) + testPair jaro "dixon" "dicksonx" (23 % 30) + testPair jaro "dicksonx" "dixon" (23 % 30) + testPair jaro "jones" "johnson" (83 % 105) + testPair jaro "johnson" "jones" (83 % 105) + testPair jaro "brain" "brian" (14 % 15) + testPair jaro "brian" "brain" (14 % 15) + testPair jaro "five" "ten" (0 % 1) + testPair jaro "ten" "five" (0 % 1) + testPair jaro "lucky" "lucky" (1 % 1) + testPair jaro "a😀c" "abc" (7 % 9) + testPair jaro "" "" (0 % 1) describe "jaroWinkler" $ do - testPair jaroWinkler "aa" "a" (17 % 20) - testPair jaroWinkler "a" "aa" (17 % 20) - testPair jaroWinkler "martha" "marhta" (173 % 180) - testPair jaroWinkler "marhta" "martha" (173 % 180) - testPair jaroWinkler "dwayne" "duane" (21 % 25) - testPair jaroWinkler "duane" "dwayne" (21 % 25) - testPair jaroWinkler "dixon" "dicksonx" (61 % 75) - testPair jaroWinkler "dicksonx" "dixon" (61 % 75) - testPair jaroWinkler "jones" "johnson" (437 % 525) - testPair jaroWinkler "johnson" "jones" (437 % 525) - testPair jaroWinkler "brain" "brian" (71 % 75) - testPair jaroWinkler "brian" "brain" (71 % 75) - testPair jaroWinkler "five" "ten" (0 % 1) - testPair jaroWinkler "ten" "five" (0 % 1) - testPair jaroWinkler "lucky" "lucky" (1 % 1) -#if __GLASGOW_HASKELL__ >= 710 - testPair jaroWinkler "a😀c" "abc" (4 % 5) -#endif - testPair jaroWinkler "" "" (0 % 1) + testPair jaroWinkler "aa" "a" (17 % 20) + testPair jaroWinkler "a" "aa" (17 % 20) + testPair jaroWinkler "martha" "marhta" (173 % 180) + testPair jaroWinkler "marhta" "martha" (173 % 180) + testPair jaroWinkler "dwayne" "duane" (21 % 25) + testPair jaroWinkler "duane" "dwayne" (21 % 25) + testPair jaroWinkler "dixon" "dicksonx" (61 % 75) + testPair jaroWinkler "dicksonx" "dixon" (61 % 75) + testPair jaroWinkler "jones" "johnson" (437 % 525) + testPair jaroWinkler "johnson" "jones" (437 % 525) + testPair jaroWinkler "brain" "brian" (71 % 75) + testPair jaroWinkler "brian" "brain" (71 % 75) + testPair jaroWinkler "five" "ten" (0 % 1) + testPair jaroWinkler "ten" "five" (0 % 1) + testPair jaroWinkler "lucky" "lucky" (1 % 1) + testPair jaroWinkler "a😀c" "abc" (4 % 5) + testPair jaroWinkler "" "" (0 % 1) + testPair jaroWinkler "aaaaaaaaaab" "aaaaaaaaaa" (54 % 55) + testPair jaroWinkler "aaaaaaaaaaaaaaaaaaaab" "aaaaaaaaaaaaaaaaaaaa" (104 % 105) describe "overlap" $ do testSwap overlap - testPair overlap "fly" "butterfly" (1 % 1) - testPair overlap "night" "nacht" (3 % 5) - testPair overlap "context" "contact" (5 % 7) - testPair overlap "red" "wax" (0 % 1) -#if __GLASGOW_HASKELL__ >= 710 - testPair overlap "a😀c" "abc" (2 % 3) -#endif + testPair overlap "fly" "butterfly" (1 % 1) + testPair overlap "night" "nacht" (3 % 5) + testPair overlap "context" "contact" (5 % 7) + testPair overlap "red" "wax" (0 % 1) + testPair overlap "a😀c" "abc" (2 % 3) testPair overlap "lucky" "lucky" (1 % 1) describe "jaccard" $ do testSwap jaccard - testPair jaccard "xxx" "xyx" (1 % 2) - testPair jaccard "night" "nacht" (3 % 7) + testPair jaccard "xxx" "xyx" (1 % 2) + testPair jaccard "night" "nacht" (3 % 7) testPair jaccard "context" "contact" (5 % 9) -#if __GLASGOW_HASKELL__ >= 710 - testPair overlap "a😀c" "abc" (2 % 3) -#endif - testPair jaccard "lucky" "lucky" (1 % 1) + testPair overlap "a😀c" "abc" (2 % 3) + testPair jaccard "lucky" "lucky" (1 % 1) -- | Test that given function returns the same results when order of -- arguments is swapped. - testSwap :: (Eq a, Show a) => (Text -> Text -> a) -> SpecWith () testSwap f = context "if we swap the arguments" $ it "produces the same result" $ - property $ \a b -> f a b === f b a + property $ \a b -> + f a b === f b a -- | Create spec for given metric function applying it to two 'Text' values -- and comparing the result with expected one. - -testPair :: (Eq a, Show a) - => (Text -> Text -> a) -- ^ Function to test - -> Text -- ^ First input - -> Text -- ^ Second input - -> a -- ^ Expected result - -> SpecWith () -testPair f a b r = it ("‘" ++ T.unpack a ++ "’ and ‘" ++ T.unpack b ++ "’") $ - f a b `shouldBe` r +testPair :: + (Eq a, Show a) => + -- | Function to test + (Text -> Text -> a) -> + -- | First input + Text -> + -- | Second input + Text -> + -- | Expected result + a -> + SpecWith () +testPair f a b r = + it ("‘" ++ T.unpack a ++ "’ and ‘" ++ T.unpack b ++ "’") $ + f a b `shouldBe` r diff --git a/text-metrics.cabal b/text-metrics.cabal --- a/text-metrics.cabal +++ b/text-metrics.cabal @@ -1,82 +1,104 @@ -name: text-metrics -version: 0.3.0 -cabal-version: >= 1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 -license: BSD3 -license-file: LICENSE.md -author: Mark Karpov -maintainer: Mark Karpov -homepage: https://github.com/mrkkrp/text-metrics -bug-reports: https://github.com/mrkkrp/text-metrics/issues -category: Text, Algorithms -synopsis: Calculate various string metrics efficiently -build-type: Simple -description: Calculate various string metrics efficiently. -extra-doc-files: CHANGELOG.md - , README.md +cabal-version: 2.4 +name: text-metrics +version: 0.3.3 +license: BSD-3-Clause +license-file: LICENSE.md +maintainer: Mark Karpov +author: Mark Karpov +tested-with: ghc ==9.6.3 ghc ==9.8.2 ghc ==9.10.1 +homepage: https://github.com/mrkkrp/text-metrics +bug-reports: https://github.com/mrkkrp/text-metrics/issues +synopsis: Calculate various string metrics efficiently +description: Calculate various string metrics efficiently. +category: Text, Algorithms +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md source-repository head - type: git - location: https://github.com/mrkkrp/text-metrics.git + type: git + location: https://github.com/mrkkrp/text-metrics.git flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True library - build-depends: base >= 4.7 && < 5.0 - , containers >= 0.5.6.2 && < 0.6 - , text >= 0.2 && < 1.3 - , vector >= 0.11 && < 0.13 - exposed-modules: Data.Text.Metrics - if flag(dev) - ghc-options: -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + exposed-modules: Data.Text.Metrics + default-language: GHC2021 + build-depends: + base >=4.15 && <5, + containers >=0.5 && <0.8, + text >=0.2 && <2.2, + vector >=0.11 && <0.14, + primitive >=0.9 && <0.10 + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall + test-suite tests - main-is: Main.hs - hs-source-dirs: tests - type: exitcode-stdio-1.0 - build-depends: QuickCheck >= 2.8 && < 3.0 - , base >= 4.7 && < 5.0 - , hspec >= 2.0 && < 3.0 - , text >= 0.2 && < 1.3 - , text-metrics - if flag(dev) - ghc-options: -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests + default-language: GHC2021 + build-depends: + QuickCheck >=2.8 && <3, + base >=4.15 && <5, + hspec >=2.0 && <3, + text >=0.2 && <2.2, + text-metrics + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall + benchmark bench-speed - main-is: Main.hs - hs-source-dirs: bench-speed - type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5.0 - , criterion >= 0.6.2.1 && < 1.3 - , deepseq >= 1.4 && < 1.5 - , text >= 0.2 && < 1.3 - , text-metrics - if flag(dev) - ghc-options: -O2 -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench/speed + default-language: GHC2021 + build-depends: + base >=4.15 && <5, + criterion >=0.6.2.1 && <1.7, + deepseq >=1.3 && <1.6, + text >=0.2 && <2.2, + text-metrics + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall + benchmark bench-memory - main-is: Main.hs - hs-source-dirs: bench-memory - type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5.0 - , deepseq >= 1.4 && < 1.5 - , text >= 0.2 && < 1.3 - , text-metrics - , weigh >= 0.0.4 - if flag(dev) - ghc-options: -O2 -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench/memory + default-language: GHC2021 + build-depends: + base >=4.15 && <5, + deepseq >=1.3 && <1.6, + text >=0.2 && <2.2, + text-metrics, + weigh >=0.0.4 + + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall