70 lines
2.0 KiB
Haskell
70 lines
2.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Main where
|
|
|
|
import Criterion.Main (bench, bgroup, defaultMain, whnf)
|
|
import Data.Char (ord)
|
|
import Data.Maybe (maybeToList)
|
|
import Data.Text (Text)
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Vector as Vector
|
|
import qualified Unicode.Char.General.Names as UnicodeNames
|
|
|
|
main = defaultMain
|
|
[ bench "naiveSearchCI" $ whnf naiveSearchCI "latin"
|
|
, bench "naiveSearchCS" $ whnf naiveSearchCS "LATIN"
|
|
, bench "memoSearchCI" $ whnf memoSearchCI "latin"
|
|
, bench "memoSearchCS" $ whnf memoSearchCS "LATIN"
|
|
]
|
|
|
|
naiveSearchCI :: Text -> [Char]
|
|
naiveSearchCI search =
|
|
filter go [minBound..maxBound]
|
|
where
|
|
go c = any matches $ allNames c
|
|
matches t = Text.toLower search `Text.isInfixOf` Text.toLower (Text.pack t)
|
|
|
|
naiveSearchCS :: Text -> [Char]
|
|
naiveSearchCS search =
|
|
filter go [minBound..maxBound]
|
|
where
|
|
go c = any matches $ allNames c
|
|
matches t = search `Text.isInfixOf` Text.pack t
|
|
|
|
memoSearchCS :: Text -> [Char]
|
|
memoSearchCS search =
|
|
filter go [minBound..maxBound]
|
|
where
|
|
go c = any matches $ allNamesText c
|
|
matches t = search `Text.isInfixOf` t
|
|
|
|
memoSearchCI :: Text -> [Char]
|
|
memoSearchCI search =
|
|
filter go [minBound..maxBound]
|
|
where
|
|
go c = any matches $ allNamesTextLower c
|
|
matches t = Text.toLower search `Text.isInfixOf` t
|
|
|
|
-- | Retrieve name and aliases (suffixed with @*@) of a 'Char'.
|
|
allNames :: Char -> [String]
|
|
allNames c =
|
|
maybeToList (UnicodeNames.name c)
|
|
++ map (++ "*") (UnicodeNames.nameAliases c)
|
|
|
|
allNamesText :: Char -> [Text]
|
|
allNamesText c = Vector.unsafeIndex textNames $ ord c
|
|
|
|
textNames :: Vector.Vector [Text]
|
|
textNames = Vector.fromList $ map go [minBound..maxBound]
|
|
where
|
|
go c = map Text.pack $ allNames c
|
|
|
|
allNamesTextLower :: Char -> [Text]
|
|
allNamesTextLower c = Vector.unsafeIndex textNamesLower $ ord c
|
|
|
|
textNamesLower :: Vector.Vector [Text]
|
|
textNamesLower = Vector.fromList $ map go [minBound..maxBound]
|
|
where
|
|
go c = map (Text.toLower . Text.pack) $ allNames c
|