diff --git a/Algorithms/NaturalSort.hs b/Algorithms/NaturalSort.hs new file mode 100644 --- /dev/null +++ b/Algorithms/NaturalSort.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algorithms.NaturalSort +-- Copyright : (c) 2010 John Millikin +-- License : BSD3 +-- +-- Maintainer : jmillikin@gmail.com +-- Portability : portable +-- +-- Human-friendly text collation +-- +----------------------------------------------------------------------------- +{-# LANGUAGE TypeSynonymInstances #-} +module Algorithms.NaturalSort + ( SortKey + , NaturalSort (..) + , compare + ) where +import Prelude hiding (compare) +import qualified Prelude as Prelude +import Data.Char (isDigit) +import Data.Function (on) +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Text.Parsec as P + +data SortChunk + = Integer Integer + | Text T.Text + | Collated B.ByteString (T.Text -> B.ByteString) + +instance Show SortChunk where + show (Integer x) = show x + show (Text x) = show x + show (Collated x _) = show x + +instance Ord SortChunk where + -- Basic comparisons + compare (Integer x) (Integer y) = Prelude.compare x y + compare (Text x) (Text y) = Prelude.compare x y + compare (Collated x _) (Collated y _) = Prelude.compare x y + + -- Text <-> ByteString + compare (Text x) (Collated y f) = Prelude.compare (f x) y + compare (Collated x f) (Text y) = Prelude.compare x (f y) + + -- Integer < * + compare (Integer _) _ = LT + compare _ (Integer _) = GT + +instance Eq SortChunk where + (Integer x) == (Integer y) = x == y + (Text x) == (Text y) = x == y + (Collated x _) == (Collated y _) = x == y + + (Text x) == (Collated y f) = f x == y + (Collated x f) == (Text y) = x == f y + + _ == _ = False + +data SortKey = SortKey [SortChunk] + deriving (Show, Eq, Ord) + +class NaturalSort a where + -- | Split a sortable type into textual and numeric sections, with no + -- collation transformation. + -- + -- If advanced collation is required, either pre-transform the input + -- (using eg 'T.toLower') or use 'sortKeyCollated'. + -- + sortKey :: a -> SortKey + + -- | Split a sortable type into textual and numeric sections, using + -- a custom collation transformation. This is useful for providing + -- language- or use-specific ordering. + -- + sortKeyCollated :: (T.Text -> B.ByteString) -> a -> SortKey + +instance NaturalSort String where + sortKey = parseText Nothing + sortKeyCollated f = parseText (Just f) + +instance NaturalSort TL.Text where + sortKey = sortKey . TL.unpack + sortKeyCollated = (. TL.unpack) . sortKeyCollated + +instance NaturalSort T.Text where + sortKey = parseText Nothing . T.unpack + sortKeyCollated = (. T.unpack) . sortKeyCollated + +-- | Compare two values, using their natural ordering. +compare :: NaturalSort a => a -> a -> Ordering +compare = Prelude.compare `on` sortKey + +parseText :: Maybe (T.Text -> B.ByteString) -> String -> SortKey +parseText toBytes string = parsed where + parsed = case P.parse parser "" string of + Right key -> key + + -- This should never happen; the parser has no failure + -- conditions, unless somehow something broke within Parsec + -- itself. + Left err -> error $ "sortKey failed: " ++ show err + + parser = fmap SortKey $ P.manyTill chunk P.eof where + chunk = P.choice [int, text] + int = fmap (Integer . read) $ P.many1 P.digit + text = fmap toText $ P.many1 notDigit + notDigit = P.satisfy (not . isDigit) + + toText chars = let text = T.pack chars in case toBytes of + Nothing -> Text text + Just f -> Collated (f text) f 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/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,26 @@ +Copyright (c) 2010 John Millikin +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 names of the copyright owners nor the names of the + 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/natural-sort.cabal b/natural-sort.cabal new file mode 100644 --- /dev/null +++ b/natural-sort.cabal @@ -0,0 +1,34 @@ +name: natural-sort +version: 0.1 +synopsis: User-friendly text collation +description: + The built-in comparisons for textual data are based on Unicode ordinals. This + does not match most every-day sorting algorithms. For example, + \"z10.txt\" is sorted after \"z2.txt\" by users, but before it by naïve + algorithms. + . + This package provides an implementation of \"natural sort\", which more + closely matches user expectations. + . + See also: + +license: BSD3 +license-File: license.txt +author: John Millikin +maintainer: John Millikin +copyright: 2010 John Millikin +build-type: Simple +cabal-version: >=1.2 +category: Algorithms + +library + build-depends: + base >= 2 && < 5 + , parsec >= 3 + , text + , bytestring + + exposed-modules: + Algorithms.NaturalSort + + ghc-options: -Wall