diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Michael Hatfield + +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 Michael Hatfield 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/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,87 @@ + +### case-insensitive-match 0.1.0.0 + +Here is a simplified library for matching and comparing strings in a +case-insensitive manner. The only dependencies are `base`, `bytestring` and +`text`. + +Usage is simple + + -- normal string comparison + "href" /= "HREF" + "apples" /= "oranges" + "Smith" < "Jones + + -- case-insensitive comparison + "href" ^== "HREF" + "appples" ^/= "oranges" + "jones" ^< "Smith" + + -- sorting some data structurue + get_names p = (last_name p,first_name p) + sortBy (caseInsensitiveComparing get_names) people + +#### Benchmarks + +The benchmarks are pretty comprehensive, offering comparisons with other +algorithms, including the `case-insensitive` package and simple case folding +using the `base` package. Before simply running the `bench-others` executable, +check the source code or you'll end up with a long series of 360 benchmark +tests. You'll want something like `bench-others -m glob ByteString/Short/*/*`, +which runs _only_ 36 benchmarks. The heirarchy is +`///`. As usual, performance +comparisons depend heavily on use-cases, but for matching shorter strings that +are often unequal this algorithm is clearly fastest. + +There is also a real-world bench test that compares different algorithms while +looking for links in an HTML file with Text.HTML.TagSoup. This bench involves +a lot of work other than string comparison, so the differences between +algorithms is slim, but usually measurable. Build an run: + + $ cabal build bench-tagsoup + ... + + $ curl -s 'https://hackage.haskell.org/packages/names' > sample/hackage-names.html + $ dist/build/bench-tagsoup/bench-tagsoup < sample/hackage-names.html + ... + + +#### Testing + +It would be quite involved to build a perfectly comprehensive testing module, +but the `test-basics` executable is tests multiple cases against all supported +data types. + + +#### Sample + +Here is a sample: + + {-# LANGUAGE OverloadedStrings #-} + + module Main ( main ) where + + import Data.List + import Data.CaseInsensitive + import qualified Data.ByteString.Char8 as BS + + main = do + stdin <- BS.getContents + let sorted_names = map join_name $ sortBy caseInsensitiveCompare $ map split_name $ BS.lines stdin + mapM_ BS.putStrLn sorted_names + + + split_name name = (last,BS.drop 2 first) + where (last,first) = BS.span (/= ',') name + + join_name (last,first) = BS.concat [ last , ", " , first ] + + +Try it with: + + $ cabal build readme-sample + ... + + $ dist/build/readme-sample/readme-sample < sample/declaration-signers.txt + + 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/case-insensitive-match.cabal b/case-insensitive-match.cabal new file mode 100644 --- /dev/null +++ b/case-insensitive-match.cabal @@ -0,0 +1,119 @@ + +name: case-insensitive-match +version: 0.1.0.0 + +license: BSD3 +license-file: LICENSE +copyright: (c) 2016 Michael Hatfield + +author: Michael Hatfield +maintainer: github@michael-hatfield.com +homepage: https://github.com/mikehat/random-strings +bug-reports: https://github.com/mikehat/random-strings + +synopsis: A simplified, faster way to do case-insensitive matching. +description: + + A way to do case-insensitive string matching and comparison with less + overhead and more speed. The 'Data.CaseInsensitive.Eq' module offers + simplified syntax and optimized instances for 'ByteString', 'String' and + 'Text'. In particular, the 'ByteString' implementation assumes ISO-8859-1 + (8-bit) encoding and performs benchmark testing significantly faster than + other implementations. + +stability: experimental +category: Text +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: README.markdown + , CHANGELOG + +source-repository head + type: git + location: git://github.com/mikehat/case-insensitive-match.git + branch: master + +source-repository this + type: git + location: git://github.com/mikehat/case-insensitive-match.git + branch: master + tag: 0.1.0.0 + + +library + exposed-modules: Data.CaseInsensitive.Eq + , Data.CaseInsensitive.Ord + , Data.CaseInsensitive + +-- Consider commenting out the previous line to avoid an impolite naming +-- conflict with the case-insensitive package. If building with cabal, a naming +-- conflict shouldn't happen unless asking for it with build-depends. + + build-depends: base ==4.* + , bytestring + , text + + hs-source-dirs: lib + default-language: Haskell2010 + + +test-suite test-basics + type: exitcode-stdio-1.0 + main-is: test-basics.hs + + build-depends: base ==4.* + , case-insensitive-match + , QuickCheck ==2.* + , mtl ==2.* + , bytestring ==0.* + , text ==1.* + + hs-source-dirs: src + default-language: Haskell2010 + + +benchmark bench-others + type: exitcode-stdio-1.0 + ghc-options: -O2 + main-is: bench-others.hs + + build-depends: base ==4.* + , bytestring ==0.* + , text ==1.* + , case-insensitive-match + , case-insensitive ==1.* + , random-strings <1.0 + , criterion + + hs-source-dirs: src + default-language: Haskell2010 + + +benchmark bench-tagsoup + type: exitcode-stdio-1.0 + ghc-options: -O2 + main-is: bench-tagsoup.hs + + build-depends: base ==4.* + , bytestring == 0.* + , case-insensitive ==1.* + , case-insensitive-match + , criterion + , tagsoup + + hs-source-dirs: src + default-language: Haskell2010 + +executable readme-example + ghc-options: -O2 + main-is: readme-example.hs + + build-depends: base + , case-insensitive-match + , bytestring + + hs-source-dirs: src + default-language: Haskell2010 + + diff --git a/lib/Data/CaseInsensitive.hs b/lib/Data/CaseInsensitive.hs new file mode 100644 --- /dev/null +++ b/lib/Data/CaseInsensitive.hs @@ -0,0 +1,23 @@ + + +{- | +module: Data.CaseInsensitive +description: All the funtionality of the "Data.CaseInsensitive.Eq" and + "Data.CaseInsensitive.Ord" modules. + +This module creates an impolite naming conflict with the @case-insensitive@ +package. If using @cabal@ to build, it's not a problem unless asked for in the +@build-depends@ directive. It is probably best to import only the +"Data.CaseInsensitive.Eq" module if that is the only functionality needed. + +-} + +module Data.CaseInsensitive + ( module Data.CaseInsensitive.Eq + , module Data.CaseInsensitive.Ord + ) +where + +import Data.CaseInsensitive.Eq +import Data.CaseInsensitive.Ord + diff --git a/lib/Data/CaseInsensitive/Eq.hs b/lib/Data/CaseInsensitive/Eq.hs new file mode 100644 --- /dev/null +++ b/lib/Data/CaseInsensitive/Eq.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances #-} + +{- | + +module: Data.CaseInsensitive.Eq +description: Simple, fast case-insensitive matching of various string types. + +This, like most other case-insensitive matching algorithms, is an +over-simplification. For some complex Q&A about properties like case, see +. A round-trip case-conversion +does not necessarily result in the original character(s) in some scripts. Also, +string matching is not necessarily the same as character matching. The +char-at-a-time approach taken here is not technically correct, but works for +the most scripts, and definitely for ASCII and the ISO-8859-1 8-bit Latin 1 +character set. + +Usage is simple: + +> main = putStrLn $ if "HREF" ^== "href" then "match" else "no match" + +-} + +module Data.CaseInsensitive.Eq + ( CaseInsensitiveEq(..) + , (^==) + , (^/=) + ) +where + +import Data.Char +import Data.Word +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +class CaseInsensitiveEq a where + caseInsensitiveEq :: a -> a -> Bool + + caseInsensitiveMatch :: [a] -> [a] -> Bool + caseInsensitiveMatch = list_eq + +-- | An equality operator for 'CaseInsensitiveEq'. +(^==) :: (CaseInsensitiveEq a) => a -> a -> Bool +(^==) = caseInsensitiveEq + + +-- | An inequality operator for 'CaseInsensitiveEq'. +(^/=) :: (CaseInsensitiveEq a) => a -> a -> Bool +(^/=) a = not . (^==) a + +------------------------------------------------------------------------------ +-- +-- instances + +instance CaseInsensitiveEq Char where + caseInsensitiveEq = char_eq + +instance (CaseInsensitiveEq a) => CaseInsensitiveEq [a] where + caseInsensitiveEq = caseInsensitiveMatch + +instance CaseInsensitiveEq Word8 where + caseInsensitiveEq = char8_eq + +instance CaseInsensitiveEq BS.ByteString where + caseInsensitiveEq = bs_strict_eq + +instance CaseInsensitiveEq BSL.ByteString where + caseInsensitiveEq = bs_lazy_eq + +instance CaseInsensitiveEq T.Text where + caseInsensitiveEq = t_strict_eq + +instance CaseInsensitiveEq TL.Text where + caseInsensitiveEq = t_lazy_eq + +instance (CaseInsensitiveEq a, CaseInsensitiveEq b) => CaseInsensitiveEq (a,b) where + caseInsensitiveEq (a,b) (a',b') + | caseInsensitiveEq a a' = True + | otherwise = caseInsensitiveEq b b' + +instance (CaseInsensitiveEq a, CaseInsensitiveEq b, CaseInsensitiveEq c) => CaseInsensitiveEq (a,b,c) where + caseInsensitiveEq (a,b,c) (a',b',c') + | caseInsensitiveEq a a' = True + | otherwise = caseInsensitiveEq (b,c) (b',c') + +instance (CaseInsensitiveEq a, CaseInsensitiveEq b, CaseInsensitiveEq c, CaseInsensitiveEq d) => CaseInsensitiveEq (a,b,c,d) where + caseInsensitiveEq (a,b,c,d) (a',b',c',d') + | caseInsensitiveEq a a' = True + | otherwise = caseInsensitiveEq (b,c,d) (b',c',d') + + + +-- | Unicode character matching. The real complexity of this masked by our +-- one-char-at-a-time approach. If all alphabetic characters were either +-- upper or lower case with a one-to-one mapping, both toUpper tests would +-- not be needed. However, there are some non-transitive and one-to-many +-- cases for Unicode characters. This is a pragmatic approach that is +-- better than using only 'toLower', which fails for some characters. +{-# INLINE char_eq #-} +char_eq :: Char -> Char -> Bool +char_eq a b + | a == b = True + | a == toLower b = True + | b == toLower a = True + | a == toUpper b = True + | b == toUpper a = True + | otherwise = False + +-- | ISO-8859-1 character matching. The code here looks wonky, but this is an +-- attempt to find the answer in as few steps as necessary. +{-# INLINE char8_eq #-} +char8_eq :: Word8 -> Word8 -> Bool +char8_eq a b + | a == b = True -- + | a < 65 || b < 65 = False -- [0..64] + | a < 91 && b < 123 = a == b - 32 -- [65..122] + | b < 91 && a < 123 = b == a - 32 -- + | a < 192 || b < 192 = False -- [123..192] + | a == 215 || b == 215 = False -- not 215 + | a < 223 = a == b - 32 -- [193..214,216..254] + | b < 223 = a - 32 == b + | otherwise = False + + +-- A two-step process for comparing ByteStrings, since length is O(1). +bs_strict_eq :: BS.ByteString -> BS.ByteString -> Bool +bs_strict_eq a b + | BS.length a /= BS.length b = False -- length is O(1) + | otherwise = continue_bs_strict_eq a b + +-- All of the following follow the same pattern, matching a character at a time. +-- If anyone can find a faster way to do this, please send it in! + +continue_bs_strict_eq a b + | BS.null a = True -- assertion: BS.null b == True after the length check + | char8_eq (BS.head a) (BS.head b) = continue_bs_strict_eq (BS.tail a) (BS.tail b) + | otherwise = False + +list_eq :: (CaseInsensitiveEq a) => [a] -> [a] -> Bool +list_eq a b + | null a || null b = null a && null b + | caseInsensitiveEq (head a) (head b) = list_eq (tail a) (tail b) + | otherwise = False + +bs_lazy_eq :: BSL.ByteString -> BSL.ByteString -> Bool +bs_lazy_eq a b + | BSL.null a || BSL.null b = BSL.null a && BSL.null b + | char8_eq (BSL.head a) (BSL.head b) = bs_lazy_eq (BSL.tail a) (BSL.tail b) + | otherwise = False + +t_strict_eq :: T.Text -> T.Text -> Bool +t_strict_eq a b + | T.null a || T.null b = T.null a && T.null b + | char_eq (T.head a) (T.head b) = t_strict_eq (T.tail a) (T.tail b) + | otherwise = False + +t_lazy_eq :: TL.Text -> TL.Text -> Bool +t_lazy_eq a b + | TL.null a || TL.null b = TL.null a && TL.null b + | char_eq (TL.head a) (TL.head b) = t_lazy_eq (TL.tail a) (TL.tail b) + | otherwise = False + diff --git a/lib/Data/CaseInsensitive/Ord.hs b/lib/Data/CaseInsensitive/Ord.hs new file mode 100644 --- /dev/null +++ b/lib/Data/CaseInsensitive/Ord.hs @@ -0,0 +1,226 @@ + +{- | +module: Data.CaseInsensitive.Ord +description: Case-insensitive comparison of strings + +Case folding of Unicode characters is a bit of a mine field, and making ordinal +comparisons of characters is sketchy as well. For example, how do we compare +alphabetic and non-alphabetic characters, or a control character and a symbol? +Unicode characters don't always have a one-to-one mapping between upper- and +lower-case, so one-at-a-time character comparisons don't necessarily make +string comparisons valid. To make things worse, some applications might have a +preference for ordering \"Apple\" ahead of \"apple\" while others would prefer them +to be 'EQ' so long as \"BANANA\" compares 'GT' to either of them. + +Herein is an attempt to combine both Unicode case folding and non-alphabetic +character comparisons in one module. @Be( a)?ware@ of the details and try to +think critically of your specific needs. + +That /slippery disclaimer/ aside, this should exhibit most people's sense of +\'normal\' behavior when comparing and ordering strings in a case-insensitive +manner. In particular, when comparing strings with all-alphanumeric characters +or strings with matching non-alphanumeric characters in /identical/ positions +this module will yield satisfying results. + +__Reasonable comparisons__: + +> "James" and "Mary" + +Two first names, no non-alphanumerics. + +> "http://www.haskell.org/" and "HTTP://WWW.EXAMPLE.COM/" + +All non-alphanumerics in matching positions until a comparison can be made. +This would be much more satisfying if the URI were parsed, even to the point of +breaking the hostname into components. + +> ("Appleseed","Johnny") and ("Bunyon","Paul") + +Comparing last-name-to-last-name and then first-to-first. + + +__Questionable comparisons__: + +> "Franklin, Benjamin" and "Hitler, Adolph" +> "Smith, Snuffy" and "Smithers, Waylon" +> "me@example.com" and "YOU@EXAMPLE.COM" + +Politics and morality aside, the @last, first@ format will inevitably result in +comparisons between a comma and an alphabetic character. The result, while +intuitively correct in this case, is so because a comma is \'less than\' a +letter for arbitrary reasons (OK, the ASCII creators probably thought deeply +about this and maybe it's not simply arbitrary). Beware when someone decides to +sort your @User@ object on @last_first@ because of some local or locale-based +assumption and the results look a little backwards to normal humans. + +> "Https://www.example.com" and "http://www.haskell.org/" + +Do all HTTP URIs come before all HTTPS ones, or should the hostname take +precedence? Again, think carefully about why you are making case-insensitive +comparisons. + +-} + +module Data.CaseInsensitive.Ord + ( CaseInsensitiveOrd(..) + , (^>) + , (^<) + , (^>=) + , (^<=) + , caseInsensitiveComparing + ) +where + +import Data.Ord +import Data.Char +import Data.Word + +import Data.CaseInsensitive.Eq + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +-- | A class for ordering strings in a case-insensitive manner. +class CaseInsensitiveOrd a where + caseInsensitiveCompare :: a -> a -> Ordering + +-- | /greater than/ for case-insensitive strings +(^>) :: (CaseInsensitiveOrd a) => a -> a -> Bool +a ^> b = caseInsensitiveCompare a b == GT + +-- | /less than/ for case-insensitive strings +(^<) :: (CaseInsensitiveOrd a) => a -> a -> Bool +a ^< b = caseInsensitiveCompare a b == LT + +-- | /greater than or equal to/ for case-insensitive strings +(^>=) :: (CaseInsensitiveOrd a) => a -> a -> Bool +a ^>= b = caseInsensitiveCompare a b /= LT + +-- | /less than or equal to/ for case-insensitive strings +(^<=) :: (CaseInsensitiveOrd a) => a -> a -> Bool +a ^<= b = caseInsensitiveCompare a b /= GT + +-- | 'comparing' for 'CaseInsensitiveOrd' +caseInsensitiveComparing :: (CaseInsensitiveOrd a) => (b -> a) -> b -> b -> Ordering +caseInsensitiveComparing f a b = caseInsensitiveCompare (f a) (f b) + + + +instance CaseInsensitiveOrd Char where + caseInsensitiveCompare = compare_char + +instance CaseInsensitiveOrd Word8 where + caseInsensitiveCompare = compare_char8 + +instance (CaseInsensitiveOrd a) => CaseInsensitiveOrd [a] where + caseInsensitiveCompare = compare_list + +instance CaseInsensitiveOrd BS.ByteString where + caseInsensitiveCompare = compare_bs + +instance CaseInsensitiveOrd BSL.ByteString where + caseInsensitiveCompare = compare_bsl + +instance CaseInsensitiveOrd T.Text where + caseInsensitiveCompare = compare_t + +instance CaseInsensitiveOrd TL.Text where + caseInsensitiveCompare = compare_tl + +instance (CaseInsensitiveOrd a,CaseInsensitiveOrd b) => CaseInsensitiveOrd (a,b) where + caseInsensitiveCompare (a,b) (a',b') = + case caseInsensitiveCompare a a' of + EQ -> caseInsensitiveCompare b b' + ord -> ord + +instance (CaseInsensitiveOrd a,CaseInsensitiveOrd b,CaseInsensitiveOrd c) => CaseInsensitiveOrd (a,b,c) where + caseInsensitiveCompare (a,b,c) (a',b',c') = + case caseInsensitiveCompare a a' of + EQ -> caseInsensitiveCompare (b,c) (b',c') + ord -> ord + +instance (CaseInsensitiveOrd a,CaseInsensitiveOrd b,CaseInsensitiveOrd c,CaseInsensitiveOrd d) => CaseInsensitiveOrd (a,b,c,d) where + caseInsensitiveCompare (a,b,c,d) (a',b',c',d') = + case caseInsensitiveCompare a a' of + EQ -> caseInsensitiveCompare (b,c,d) (b',c',d') + ord -> ord + + +-- | Compare Char +{-# INLINE compare_char #-} +compare_char :: Char -> Char -> Ordering +compare_char a b + | caseInsensitiveEq a b = EQ + | otherwise = compare (toUpper a) (toUpper b) + +-- | Compare 8-bit ISO-8859-1 words. +{-# INLINE compare_char8 #-} +compare_char8 :: Word8 -> Word8 -> Ordering +compare_char8 a b + | a == b = EQ + | a < 65 || b < 65 = compare a b + | a < 97 && b < 97 = compare a b + | a < 91 && b < 123 = compare a (b - 32) + | b < 91 && a < 123 = compare (a - 32) b + | a < 216 && b < 216 = compare a b + | a == 247 = GT + | b == 247 = LT + | a == 215 = compare a (b - 32) + | b == 215 = compare (a - 32) b + | a < 224 = compare a (b - 32) + | b < 224 = compare (a - 32) b + | otherwise = compare a b + + +compare_list :: (CaseInsensitiveOrd a) => [a] -> [a] -> Ordering +compare_list a b + | null a && null b = EQ + | null a = LT + | null b = GT + | otherwise = + case caseInsensitiveCompare (head a) (head b) of + EQ -> compare_list (tail a) (tail b) + ord -> ord + +compare_bs :: BS.ByteString -> BS.ByteString -> Ordering +compare_bs a b + | BS.null a && BS.null b = EQ + | BS.null a = LT + | BS.null b = GT + | otherwise = + case caseInsensitiveCompare (BS.head a) (BS.head b) of + EQ -> compare_bs (BS.tail a) (BS.tail b) + ord -> ord + +compare_bsl :: BSL.ByteString -> BSL.ByteString -> Ordering +compare_bsl a b + | BSL.null a && BSL.null b = EQ + | BSL.null a = LT + | BSL.null b = GT + | otherwise = + case caseInsensitiveCompare (BSL.head a) (BSL.head b) of + EQ -> compare_bsl (BSL.tail a) (BSL.tail b) + ord -> ord + +compare_t :: T.Text -> T.Text -> Ordering +compare_t a b + | T.null a && T.null b = EQ + | T.null a = LT + | T.null b = GT + | otherwise = + case caseInsensitiveCompare (T.head a) (T.head b) of + EQ -> compare_t (T.tail a) (T.tail b) + ord -> ord + +compare_tl :: TL.Text -> TL.Text -> Ordering +compare_tl a b + | TL.null a && TL.null b = EQ + | TL.null a = LT + | TL.null b = GT + | otherwise = + case caseInsensitiveCompare (TL.head a) (TL.head b) of + EQ -> compare_tl (TL.tail a) (TL.tail b) + ord -> ord + diff --git a/src/bench-others.hs b/src/bench-others.hs new file mode 100644 --- /dev/null +++ b/src/bench-others.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE PackageImports , TupleSections , MultiParamTypeClasses , FlexibleInstances #-} + +{- | + +Run comparative benchmarks against other Haskell implementations. + +The only other common implementation in Hackage is @case-insensitive@. That +algorithm and a simple one using @map toLower@ (and similar implementations) +are included in these benchmarks. + +The random strings generated are limited to the printable ASCII characters. +The ratios of alphabetic and upper-case characters in the strings are part of +the randomization of the strings. The ratios chosen are shown below. The +character makeup of the test strings appears to have only slight effect on any +performance differences between the algorithms tested. + +The lengths of the test strings are a little more impactful on the benches, so +two options are explored: short (random length) and long. The short strings are +likely what will be matched in the real world. The case folding routines +probably have similar performance, so the differences in string handling in +general and in allocation in particular exaggerate the difference in benchmark +performance. Even the lazily evaluated string in the @case-insensitive@ library +is noticeably slower because a second string is allocated. + +The biggest difference in speed is for string comparisons that fail. When +matching short strings in a larger stream, the non-match is probably the +dominant case. The 'CaseInsensitiveEq' algorithm is by far the fastest. + +Benchmarks available form a four-dimensional matrix accessible in the +tree-like, path-based style of @Criterion@'s defaultMain command line +handling. + +> bench-others -m glob ByteString.Lazy/short/*/* + +The axes and values are: + + - string type: data type of strings to compare + + -- @String@ + -- @ByteString@ + -- @ByteString.Lazy@ + -- @Text@ + -- @Text.Lazy@ + + - string length: + + -- @short@ - 1000 different random-length (2-12 chars) strings + -- @long@ - 20 different 500-char strings + + - string case: comparing the original with ... + + -- @id@ - identical strings + -- @toLower@ - a lower-case version of the original + -- @toUpper@ - an upper-case version of the original + -- @flipCase@ - all alphabetic characters in the opposite case + -- @similar@ - identical at the beginning, then different + -- @different@ - different string from the first character + + - match algorithm: + + -- @FoldCase@ - compare two case-folded strings using @base@ library + -- @CaseInsensitiveEq@ - compare using this library + -- @CIeq@ - compare using the @case-insensitive@ package + -- @CIeq'@ - a smarter use of @case-insensitive@, assuming one string is a literal in client code + -- @FoldCaseOrd@ - ordering or two case-folded strings using the @base@ library + -- @CaseInsensitiveOrd@ - ordering using this library + +Note on @CIeq'@: There is some overhead to using 'CI.mk". In most cases, one of +the two strings being compared will be a string literal in the client source +code. We can assume that 'CI.mk' will be called for the literal at most once, +if not never, during execution. The @CIeq'@ comparison algorithm (sometimes the +fastest) models this case by evaluating one half of the comparison before the +benchmark begins. This might also be informative for the @FoldCase@ algorithm, +but it's not explored here. + +-} + +module Main ( main ) where + +import Test.RandomStrings +import Test.RandomStrings.FlipCase +import Criterion.Main + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import Data.Ratio ( (%) ) +import Data.Word +import Data.Char +import Data.String ( IsString(..) ) + +import qualified "case-insensitive" Data.CaseInsensitive as CI +import Data.CaseInsensitive.Eq +import Data.CaseInsensitive.Ord + + + + +------------------------------------------------------------------------------ +-- +-- | 'main' first generates some random test strings and then organizes bench +-- groups in a tree organized by +-- +-- @/ types / length / case / method@ +-- +main = do + strings <- mapM mk_strings + [ StringLengthShort + , StringLengthLong + ] + + defaultMain + [ bgroup "String" $ map (mk_length "" ) strings + , bgroup "ByteString" $ map (mk_length BS.empty ) strings + , bgroup "ByteString.Lazy" $ map (mk_length BSL.empty) strings + , bgroup "Text" $ map (mk_length T.empty ) strings + , bgroup "Text.Lazy" $ map (mk_length TL.empty ) strings + ] + + + +------------------------------------------------------------------------------ +-- +-- generating random test strings +-- + +-- | Test strings are all printable characters in the 7-bit ASCII range. The +-- mix is 9/10 alphabetic and the alphabetic characters are 1/6 upper case. +-- If the mix of character classes made much difference in benchmark +-- results, I'd add these as command line parameters. To try a different +-- mix, modify it here. +string_generator = randomString' randomASCII (9%10) (1%6) + +data StringLengthOption = StringLengthLong | StringLengthShort deriving Eq + +mk_strings :: StringLengthOption -> IO (StringLengthOption,[String]) +mk_strings StringLengthShort = randomStringsLen string_generator (2,12) 1000 >>= \s -> return (StringLengthShort,s) +mk_strings StringLengthLong = randomStrings (string_generator 500) 20 >>= \s -> return (StringLengthLong,s) + + +------------------------------------------------------------------------------ +-- +-- | CaseOption describes the change made to the original string to make a +-- testable pair of strings. Most create a pair that should be equivalent +-- in case-insensitive comparisons. +data CaseOption = CaseId | CaseToLower | CaseToUpper | CaseFlipCase | CaseSimilar | CaseDifferent + +-- | Creating the pairs used by the comparison algorithms. The extra 'Bool' is +-- what the result of a case-insensitive comparison should be. +mk_pair :: CaseOption -> String -> ((String,String),Bool) +mk_pair CaseId a = ((a,a),True) +mk_pair CaseToLower a = ((a,map toLower a),True) +mk_pair CaseToUpper a = ((a,map toUpper a),True) +mk_pair CaseFlipCase a = ((a,map flipCase a),True) +mk_pair CaseSimilar a = ((a, mk_similar a), False) +mk_pair CaseDifferent a = ((a,mk_different a),False) + + +-- | Make a different String after a 'random' number of chars. +-- Guaranteed to be different from the original. +mk_similar [] = [] +mk_similar as@(a:_) = (take n as') ++ (map succ as'') + where + n = (fromEnum a) `mod` (length as) + (as',as'') = splitAt n as + +-- | Make a completely different string than the original. +mk_different = map succ + + +pack_pair :: (IsString a) => a -> ((String,String),b) -> ((a,a),b) +pack_pair _ ((a,b),c) = ((fromString a,fromString b),c) + +ci_mk_pair :: (CI.FoldCase a) => ((a,a),b) -> ((CI.CI a,a),b) +ci_mk_pair ((a,b),c) = ((CI.mk a,b),c) + +-- | make a bench group for a StringLengthOption +mk_length :: (BenchType a) => a -> (StringLengthOption,[String]) -> Benchmark +mk_length s (len_opt,strings) = bgroup (bench_name len_opt) $ + map (mk_case s strings) + [ CaseId -- the original string + , CaseToLower -- a lower-case version of the original + , CaseToUpper -- an upper-case version of the original + , CaseFlipCase -- a version with inverted case for alphabetic chars + , CaseSimilar -- a version that is initially equivalent, but not fully so + , CaseDifferent -- a completely different string from the first character + ] + +------------------------------------------------------------------------------ +-- +-- The leaf nodes evaluate different comparison algorithms on the pairs of +-- randomly generated string. These are the actual benchmark tests, and the +-- pairs of strings being generated are fully constructed before the tests +-- because they are the final parameter of 'nf'. + + +-- | make a bench group for a CaseOption +mk_case :: (BenchType a) => a -> [String] -> CaseOption -> Benchmark +mk_case s strings case_opt = bgroup (bench_name case_opt) + [ bench "FoldCase" $ nf (map $ \((a,b),tf) -> (((fold_case_bench a) == (fold_case_bench b)) == tf || assert_fail)) $ (map (pack_pair s) pairs) + , bench "CaseInsensitiveEq" $ nf (map $ \((a,b),tf) -> ((caseInsensitiveEq a b ) == tf || assert_fail)) $ (map (pack_pair s) pairs) + , bench "CIeq" $ nf (map $ \((a,b),tf) -> (((CI.mk a) == (CI.mk b) ) == tf || assert_fail)) $ (map (pack_pair s) pairs) + , bench "CIeq'" $ nf (map $ \((a,b),tf) -> ((a == (CI.mk b) ) == tf || assert_fail)) $ (map ci_mk_pair $ map (pack_pair s) pairs) + , bench "FoldCaseOrd" $ nf (map $ \((a,b),tf) -> ((compare (fold_case_bench a) (fold_case_bench b) == EQ) == tf || assert_fail)) $ (map (pack_pair s) pairs) + , bench "CaseInsensitiveOrd" $ nf (map $ \((a,b),tf) -> ((caseInsensitiveCompare a b == EQ) == tf || assert_fail)) $ (map (pack_pair s) pairs) + ] + where + pairs = map (mk_pair case_opt) strings + assert_fail = error "internal: assertion failed" + + +------------------------------------------------------------------------------ +-- +-- classes + + +-- | A class for string types to be benchmarked. Both 'CaseInsensitiveEq' and +-- 'CI.FoldCase' are ready to be tested as-is, but the case-folding algorithm +-- that only relies on the @base@ package requires an implementation of +-- case-folding for each string type. +class (CI.FoldCase a, CaseInsensitiveEq a, Eq a, CaseInsensitiveOrd a, Ord a, IsString a) => BenchType a where + fold_case_bench :: a -> a + +instance BenchType String where + fold_case_bench = map toLower + +instance BenchType BS.ByteString where + fold_case_bench = BS8.map toLower + +instance BenchType BSL.ByteString where + fold_case_bench = BSL8.map toLower + +instance BenchType T.Text where + fold_case_bench = T.map toLower + +instance BenchType TL.Text where + fold_case_bench = TL.map toLower + + + +-- | A helper class for naming branches of the bench tree. +class NamedBench a where bench_name :: a -> String + +instance NamedBench String where bench_name = const "String" +instance NamedBench BS.ByteString where bench_name = const "ByteString" +instance NamedBench BSL.ByteString where bench_name = const "ByteString.Lazy" +instance NamedBench T.Text where bench_name = const "Text" +instance NamedBench TL.Text where bench_name = const "Text.Lazy" + +instance NamedBench StringLengthOption where + bench_name StringLengthLong = "Long" + bench_name StringLengthShort = "Short" + +instance NamedBench CaseOption where + bench_name CaseId = "id" + bench_name CaseToLower = "toLower" + bench_name CaseToUpper = "toUpper" + bench_name CaseFlipCase = "flipCase" + bench_name CaseSimilar = "similar" + bench_name CaseDifferent = "different" + diff --git a/src/bench-tagsoup.hs b/src/bench-tagsoup.hs new file mode 100644 --- /dev/null +++ b/src/bench-tagsoup.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings , PackageImports #-} + + +{- | Benchmarking TagSoup to extract a/@href from a web page. The results are + not at all shocking, but do show differences between packages. The easier + syntax and slight speed improvement of the @case-insensitive-match@ + package. The time differences seem consistent, showing that when parsing + an html page there is significant time doing case-insensitive string + comparison. + + Note: I'm not sure why Criterion shows a faster run the first time tags + are parsed. I added an @init@ bench to make the others look normal. The + same thing usually happens no matter the matching algorithm. You can try + running only one bench at a time and comparing the higher-speed results. + +-} +module Main ( main ) where + +import Criterion.Main +import Data.String + +import Text.HTML.TagSoup +import Text.HTML.TagSoup.Match +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString ( ByteString ) + +import qualified "case-insensitive" Data.CaseInsensitive as CI +import Data.CaseInsensitive.Eq + +main = do + html <- BS.getContents + let tags = parseTags html + if True -- set to False to actually see the list of HREFs + then + defaultMain + [ bgroup "match-only" + [ bench "init" $ nf (findLinks (^==) ) tags + , bench "==" $ nf (findLinks (==) ) tags + , bench "CaseInsensitiveEq" $ nf (findLinks (^==) ) tags + , bench "CIeq" $ nf (findLinks ciEq ) tags + , bench "CIeq'" $ nf (findLinks ciEq' ) tags + ] + , bgroup "parse-and-match" + [ bench "init" $ nf (findLinks (^==) . parseTags ) html + , bench "==" $ nf (findLinks (==) . parseTags ) html + , bench "CaseInsensitiveEq" $ nf (findLinks (^==) . parseTags ) html + , bench "CIeq" $ nf (findLinks ciEq . parseTags ) html + , bench "CIeq'" $ nf (findLinks ciEq' . parseTags ) html + ] + ] + else + mapM_ BS8.putStrLn $ findLinks (^==) tags + +-- see bench-others for the reasoning behind these two algorithms +ciEq a b = (CI.mk a) == (CI.mk b) +ciEq' a b = a == (CI.mk b) + +findLinks :: (IsString a) => (a -> ByteString -> Bool) -> [Tag ByteString] -> [ByteString] +findLinks eq [] = [] +findLinks eq (tag:tags) + | tagOpen (eq "a") (const True) tag = get_tag_href eq tag : findLinks eq tags + | otherwise = findLinks eq tags + +get_tag_href eq (TagOpen _ attrs) = get_href eq attrs +get_tag_href _ _ = error "internal: tagOpen failed!" + +get_href _ [] = BS.empty +get_href eq ((n,v):attrs) + | eq "href" n = v + | otherwise = get_href eq attrs + diff --git a/src/readme-example.hs b/src/readme-example.hs new file mode 100644 --- /dev/null +++ b/src/readme-example.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main ( main ) where + +import Data.List +import Data.CaseInsensitive +import qualified Data.ByteString.Char8 as BS + +main = do + stdin <- BS.getContents + let sorted_names = map join_name $ sortBy caseInsensitiveCompare $ map split_name $ BS.lines stdin + mapM_ BS.putStrLn sorted_names + + +split_name name = (last,BS.drop 2 first) + where (last,first) = BS.span (/= ',') name + +join_name (last,first) = BS.concat [ last , ", " , first ] + diff --git a/src/test-basics.hs b/src/test-basics.hs new file mode 100644 --- /dev/null +++ b/src/test-basics.hs @@ -0,0 +1,368 @@ + +{- + +-} + +module Main ( main ) where + + +import Data.Char +import Data.Word +import Data.Maybe ( catMaybes ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import Control.Monad.State +import System.Exit + +import Data.CaseInsensitive + + +main = do + success <- flip execStateT True $ do + doTest "all Char Eq" test_AllCharEqChar + doTest "all Word8 Eq" test_AllCharEqWord8 + doTest "all Char Eq String" test_AllCharEqString + doTest "all Char using caseInsensitiveMatch" test_AllCharMatchChar + doTest "all Word8 Eq Strict ByteString" test_AllCharEqBS + doTest "all Word8 Eq Lazy ByteString" test_AllCharEqBSL + doTest "unequal String cases" test_NotEqualString + doTest "unequal ByteString cases" test_NotEqualBS + doTest "unequal Lazy ByteString cases" test_NotEqualBSL + doTest "unequal Text cases" test_NotEqualT + doTest "unequal Lazy Text cases" test_NotEqualTL + doTest "equal String cases" test_EqualString + doTest "equal ByteString cases" test_EqualBS + doTest "equal Lazy ByteString cases" test_EqualBSL + doTest "equal Text cases" test_EqualT + doTest "equal Lazy Text cases" test_EqualTL + doTest "equal ByteStrirg tuple" test_EqualTupleBS + doTest "compare all Char EQ" test_CompareAllCharEQChar + doTest "compare all Char8 EQ" test_CompareAllCharEQWord8 + doTest "compare all String EQ" test_CompareAllCharEQString + doTest "compare all ByteString EQ" test_CompareAllByteStringEQ + doTest "compare unequal String cases" test_OrderString + doTest "compare unequal ByteString cases" test_OrderByteString + doTest "compare unequal Text cases" test_OrderText + doTest "compare equal String cases" test_CompareEQString + doTest "compare equal ByteString cases" test_CompareEQByteString + doTest "compare equal Text cases" test_CompareEQText + doTest "compare equal ByteString tuple" test_CompareEQTupleBS + doTest "compare unequal ByteString tuple" test_CompareGTTupleBS + + if success then exitSuccess else exitFailure + +-- | All tests are of the simple pass/fail variety. This is meant +-- at a certain level to emulate QuickCheck. +doTest :: String -> Bool -> StateT Bool IO () +doTest name test = do + liftIO $ putStr $ take 40 $ concat [ name , ":" , repeat ' ' ] + if test + then do + liftIO $ putStrLn "+++ OK, passed" + else do + liftIO $ putStrLn "--- Failed!" + put False + + +------------------------------------------------------------------------------ +-- +-- Testing all character values for each instance. +-- +-- + +-- Test the case-folding behavior of one-at-a-time character matching. A +-- highly technical implementation would not match Unicode Char and String +-- using the same algorithm. The instance for Char is pragmatic enough to pass, +-- but this is a test that the case-insensitive package fails. + +test_AllCharEqChar :: Bool +test_AllCharEqChar = + all id + [ all (uncurry caseInsensitiveEq) $ zip all_chars all_chars + , all (uncurry caseInsensitiveEq) $ zip all_chars all_uppers + , all (uncurry caseInsensitiveEq) $ zip all_chars all_lowers + , not $ all_chars == all_uppers -- validating toUpper, actually + , not $ all_chars == all_lowers + ] + where + all_chars = [minBound..maxBound] :: [Char] + all_uppers = map toUpper all_chars + all_lowers = map toLower all_chars + +test_AllCharEqWord8 :: Bool +test_AllCharEqWord8 = + all id + [ all (uncurry caseInsensitiveEq) $ zip all_chars all_chars + , all (uncurry caseInsensitiveEq) $ zip all_chars all_uppers + , all (uncurry caseInsensitiveEq) $ zip all_chars all_lowers + , not $ all_chars == all_uppers -- validating fold_8 toUpper, actually + , not $ all_chars == all_lowers + ] + where + all_chars = [minBound..maxBound] :: [Word8] + all_uppers = map (fold_8 toUpper) all_chars + all_lowers = map (fold_8 toLower) all_chars + +test_AllCharMatchChar :: Bool +test_AllCharMatchChar = + all id + [ all_chars `caseInsensitiveMatch` all_chars + , all_chars `caseInsensitiveMatch` all_uppers + , all_chars `caseInsensitiveMatch` all_lowers + , not $ all_chars == all_uppers -- validating map toUpper, actually + , not $ all_chars == all_lowers + ] + where + all_chars = [minBound..maxBound] :: [Char] + all_uppers = map toUpper all_chars + all_lowers = map toUpper all_chars + +test_AllCharEqString :: Bool +test_AllCharEqString = + all id + [ all_chars `caseInsensitiveEq` all_chars + , all_chars `caseInsensitiveEq` all_uppers + , all_chars `caseInsensitiveEq` all_lowers + , not $ all_chars == all_uppers -- validating map toUpper, actually + , not $ all_chars == all_lowers + ] + where + all_chars = [minBound..maxBound] :: [Char] + all_uppers = map toUpper all_chars + all_lowers = map toUpper all_chars + +test_AllCharEqBS :: Bool +test_AllCharEqBS = + all id + [ all_chars `caseInsensitiveEq` all_chars + , all_chars `caseInsensitiveEq` all_uppers + , all_chars `caseInsensitiveEq` all_lowers + , not $ all_chars == all_uppers -- validating fold_8 toUpper, actually + , not $ all_chars == all_lowers + ] + where + all_chars = BS.pack $ [minBound..maxBound] + all_uppers = BS.map (fold_8 toUpper) all_chars + all_lowers = BS.map (fold_8 toLower) all_chars + +test_AllCharEqBSL :: Bool +test_AllCharEqBSL = + all id + [ all_chars `caseInsensitiveEq` all_chars + , all_chars `caseInsensitiveEq` all_uppers + , all_chars `caseInsensitiveEq` all_lowers + , not $ all_chars == all_uppers -- validating fold_8 toUpper, actually + , not $ all_chars == all_lowers + ] + where + all_chars = BSL.pack $ [minBound..maxBound] + all_uppers = BSL.map (fold_8 toUpper) all_chars + all_lowers = BSL.map (fold_8 toLower) all_chars + +------------------------------------------------------------------------------ +-- +-- Ord +-- + +test_CompareAllCharEQChar :: Bool +test_CompareAllCharEQChar = + all id + [ all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_chars + , all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_uppers + , all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_lowers + ] + where + all_chars = [minBound..maxBound] :: [Char] + all_uppers = map toUpper all_chars + all_lowers = map toLower all_chars + + +test_CompareAllCharEQWord8 :: Bool +test_CompareAllCharEQWord8 = + all id + [ all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_chars + , all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_uppers + , all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_lowers + ] + where + all_chars = [minBound..maxBound] :: [Word8] + all_uppers = map (fold_8 toUpper) all_chars + all_lowers = map (fold_8 toLower) all_chars + +test_CompareAllCharEQString :: Bool +test_CompareAllCharEQString = + all id + [ caseInsensitiveCompare all_chars all_chars == EQ + , caseInsensitiveCompare all_chars all_uppers == EQ + , caseInsensitiveCompare all_chars all_lowers == EQ + ] + where + all_chars = [minBound..maxBound] :: [Char] + all_uppers = map toUpper all_chars + all_lowers = map toLower all_chars + +test_CompareAllByteStringEQ :: Bool +test_CompareAllByteStringEQ = + all id + [ caseInsensitiveCompare all_chars all_chars == EQ + , caseInsensitiveCompare all_chars all_uppers == EQ + , caseInsensitiveCompare all_chars all_lowers == EQ + ] + where + all_chars = BS.pack $ [minBound..maxBound] + all_uppers = BS.map (fold_8 toUpper) all_chars + all_lowers = BS.map (fold_8 toLower) all_chars + + + +------------------------------------------------------------------------------ +-- +-- A few test cases with strings that should not match. +-- + +neq_cases = + [ (( "apples" , "oranges" ) , LT) + , (( "apples" , "apple" ) , GT) + , (( "123" , "" ) , GT) + , (( "" , "abc" ) , LT) + , (( a_to_z , z_to_a ) , LT) + ] + where + a_to_z = ['a'..'z'] + z_to_a = reverse a_to_z + + +neq_pairs = map fst neq_cases + +neq_cases_bs = map (\((a,b),c) -> ((BS.pack a,BS.pack b),c)) $ cases_to_word8 neq_cases +neq_pairs_bs = map (\(a,b) -> (BS.pack a ,BS.pack b )) $ pairs_to_word8 neq_pairs + +neq_cases_bsl = map (\((a,b),c) -> ((BSL.pack a,BSL.pack b),c)) $ cases_to_word8 neq_cases +neq_pairs_bsl = map (\(a,b) -> (BSL.pack a,BSL.pack b)) $ pairs_to_word8 neq_pairs + +neq_cases_t = map (\((a,b),c) -> ((T.pack a,T.pack b),c)) $ neq_cases +neq_pairs_t = map (\(a,b) -> (T.pack a ,T.pack b )) $ neq_pairs + +neq_cases_tl = map (\((a,b),c) -> ((TL.pack a,TL.pack b),c)) $ neq_cases +neq_pairs_tl = map (\(a,b) -> (TL.pack a,TL.pack b)) $ neq_pairs + +test_NotEqualString :: Bool +test_NotEqualString = all not $ map (uncurry caseInsensitiveEq) neq_pairs + +test_NotEqualBS :: Bool +test_NotEqualBS = all not $ map (uncurry caseInsensitiveEq) neq_pairs_bs + +test_NotEqualBSL :: Bool +test_NotEqualBSL = all not $ map (uncurry caseInsensitiveEq) neq_pairs_bsl + +test_NotEqualT :: Bool +test_NotEqualT = all not $ map (uncurry caseInsensitiveEq) neq_pairs_t + +test_NotEqualTL :: Bool +test_NotEqualTL = all not $ map (uncurry caseInsensitiveEq) neq_pairs_tl + +test_OrderString :: Bool +test_OrderString = all id $ map (\((a,b),c) -> caseInsensitiveCompare a b == c) neq_cases + +test_OrderByteString :: Bool +test_OrderByteString = all id $ map (\((a,b),c) -> caseInsensitiveCompare a b == c) neq_cases_bs + +test_OrderText :: Bool +test_OrderText = all id $ map (\((a,b),c) -> caseInsensitiveCompare a b == c) neq_cases_t + +------------------------------------------------------------------------------ +-- +-- A few test cases with strings that should match. +-- + +case_eq_pairs = + [ ( "apples" , "apples" ) + , ( "example.com" , "EXAMPLE.com" ) + , ( "HTML" , "html" ) + , ( "Content-Type" , "CONTENT-TYPE" ) + , ( "C:\\Windows" , "c:\\windows" ) + ] + +case_eq_pairs_bs = map (\(a,b) -> (BS.pack a ,BS.pack b )) $ pairs_to_word8 case_eq_pairs +case_eq_pairs_bsl = map (\(a,b) -> (BSL.pack a,BSL.pack b)) $ pairs_to_word8 case_eq_pairs + +case_eq_pairs_t = map (\(a,b) -> (T.pack a ,T.pack b )) $ case_eq_pairs +case_eq_pairs_tl = map (\(a,b) -> (TL.pack a,TL.pack b)) $ case_eq_pairs + +test_EqualString :: Bool +test_EqualString = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs + +test_EqualBS :: Bool +test_EqualBS = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs_bs + +test_EqualBSL :: Bool +test_EqualBSL = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs_bsl + +test_EqualT :: Bool +test_EqualT = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs_t + +test_EqualTL :: Bool +test_EqualTL = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs_tl + +test_CompareEQString :: Bool +test_CompareEQString = all id $ map ((==EQ) . uncurry caseInsensitiveCompare) case_eq_pairs + +test_CompareEQByteString :: Bool +test_CompareEQByteString = all id $ map ((==EQ) . uncurry caseInsensitiveCompare) case_eq_pairs_bs + +test_CompareEQText :: Bool +test_CompareEQText = all id $ map ((==EQ) . uncurry caseInsensitiveCompare) case_eq_pairs_t + +------------------------------------------------------------------------------ +-- +-- tuple instances - testing all recursively +-- + +test_EqualTupleBS :: Bool +test_EqualTupleBS = + ("apple","oranges","me@example.com","Content-Type") + ^== + ("APPLE","Oranges","me@EXAMPLE.COM","content-type") + +test_CompareEQTupleBS :: Bool +test_CompareEQTupleBS = + ( caseInsensitiveCompare + ("apple","oranges","me@example.com","Content-Type") + ("APPLE","Oranges","me@EXAMPLE.COM","content-type") + ) == EQ + + +test_CompareGTTupleBS :: Bool +test_CompareGTTupleBS = + ( caseInsensitiveCompare + ("apple","oranges","me@example.com",("Content-Type","text/html")) + ("APPLE","Oranges","me@EXAMPLE.COM",("content-language","en-us")) + ) == GT + + +------------------------------------------------------------------------------ +-- +-- utility functions for creating Word8 strings +-- + +char_to_word8 :: Char -> Maybe Word8 +char_to_word8 c + | fromEnum c > 256 = Nothing + | otherwise = Just $ fromIntegral $ fromEnum c + +string_to_word8s :: String -> [Word8] +string_to_word8s = catMaybes . map char_to_word8 + +cases_to_word8 = map (\((a,b),c) -> ((string_to_word8s a,string_to_word8s b),c)) +pairs_to_word8 = map (\(a,b) -> (string_to_word8s a , string_to_word8s b)) + + +-- Some of the lower-256 actually have upper-case outside that range. Here, +-- we treat those as if they didn't have any case at all. +fold_8 :: (Char -> Char) -> Word8 -> Word8 +fold_8 f c + | ( fromEnum $ f $ toEnum $ fromIntegral c) > 255 = c + | otherwise = fromIntegral $ fromEnum $ f $ toEnum $ fromIntegral c