Add search benchmark

.gitignore

@@ -1,4 +1,6 @@
 .stack-work/
+dist-newstyle
 .vscode/
 *.swp
 result
+bench.html

README.md

@@ -35,4 +35,5 @@ $ nix run .#ghc
 
 ## TODO
 
-- [ ] Benchmark, profile and optimize search
+- [x] Benchmark, profile and optimize search
+- [ ] Trim down the docker image

bench/Main.hs

@@ -0,0 +1,69 @@
+{-# 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

flake.nix

@@ -31,6 +31,7 @@
               pkgs.haskellPackages.implicit-hie
               pkgs.haskell-language-server
             ];
+          cabal2nixOptions = "--benchmark";
         }).env;
   };
 }

hie.yaml

@@ -1,10 +1,10 @@
 cradle:
-  stack:
+  cabal:
-    - path: "./src"
+    - path: "src"
-      component: "utoy:lib"
+      component: "lib:utoy"
 
-    - path: "./app/Main.hs"
+    - path: "app/Main.hs"
       component: "utoy:exe:utoy"
 
-    - path: "./test"
+    - path: "bench/Main.hs"
-      component: "utoy:test:utoy-test"
+      component: "utoy:bench:utoy-bench"

test/Spec.hs

@@ -1,2 +0,0 @@
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"

utoy.cabal

@@ -1,9 +1,5 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.2.
---
--- see: https://github.com/sol/hpack
-
 name:           utoy
 version:        0.6.1
 author:         Paul Brinkmeier
@@ -57,17 +53,15 @@ executable utoy
     , warp
   default-language: Haskell2010
 
-test-suite utoy-test
+benchmark utoy-bench
   type: exitcode-stdio-1.0
-  main-is: Spec.hs
+  main-is: Main.hs
-  other-modules:
-      Paths_utoy
   hs-source-dirs:
-      test
+    bench
-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      attoparsec
+      base >=4.7 && <5
-    , base >=4.7 && <5
+    , criterion
     , text
-    , utoy
+    , unicode-data-names
+    , vector
   default-language: Haskell2010