feat: colorized search output

Author: head-gardener

src/Action/Search.hs

@@ -21,7 +21,10 @@ import qualified Data.Set as Set
 import System.Directory
 import Text.Blaze.Renderer.Utf8
 import Safe
-import System.Console.ANSI (hSupportsANSI, hyperlinkCode)
+import System.Console.ANSI
+    (hSupportsANSI, hyperlinkCode, setSGRCode
+    ,SGR (SetColor), ConsoleLayer (Foreground)
+    ,ColorIntensity (Vivid, Dull), Color (Yellow))
 import System.IO (stdout)
 
 import Action.CmdLine
@@ -46,19 +49,18 @@ actionSearch Search{..} = replicateM_ repeat_ $ -- deliberately reopen the datab
             count' <- pure $ fromMaybe 10 count
             (q, res) <- pure $ search store $ parseQuery $ unwords query
             whenLoud $ putStrLn $ "Query: " ++ unescapeHTML (LBS.unpack $ renderMarkup $ renderQuery q)
-            hyperlink <- case color of
+            color' <- case color of
               Just b -> pure b
               Nothing -> hSupportsANSI stdout
-            let (shown, hidden) = splitAt count' $ nubOrd $ map (targetResultDisplay link hyperlink) res
+            let (shown, hidden) = splitAt count' $ nubOrd $ map (targetResultDisplay link color' q) res
             if null res then
                 putStrLn "No results found"
              else if info then do
-                 putStr $ targetInfo $ headErr res
+                 putStr $ targetInfo color' q $ headErr res
              else do
-                let toShow = if numbers && not info then addCounter shown else shown
                 if | json -> LBS.putStrLn $ JSON.encode $ maybe id take count $ map unHTMLtargetItem res
                    | jsonl -> mapM_ (LBS.putStrLn . JSON.encode) $ maybe id take count $ map unHTMLtargetItem res
-                   | otherwise -> putStr $ unlines toShow
+                   | otherwise -> putStr $ unlines $ if numbers then addCounter shown else shown
                 when (hidden /= [] && not json) $ do
                     whenNormal $ putStrLn $ "-- plus more results not shown, pass --count=" ++ show (count'+10) ++ " to see more"
         else do
@@ -68,22 +70,29 @@ actionSearch Search{..} = replicateM_ repeat_ $ -- deliberately reopen the datab
             putStr $ unlines $ searchFingerprintsDebug store (parseType $ unwords query) (map parseType compare_)
 
 -- | Returns the details printed out when hoogle --info is called
-targetInfo :: Target -> String
-targetInfo Target{..} =
-    unlines $ [ unHTML targetItem ] ++
+targetInfo :: Bool -> [Query] -> Target -> String
+targetInfo color qs Target{..} =
+    unlines $ [ unHTML . (if color then ansiHighlight qs else id) $ targetItem ] ++
               [ unwords packageModule | not $ null packageModule] ++
               [ unHTML targetDocs ]
             where packageModule = map fst $ catMaybes [targetPackage, targetModule]
 
 -- | Returns the Target formatted as an item to display in the results
--- | Bool argument decides whether links are shown
-targetResultDisplay :: Bool -> Bool -> Target -> String
-targetResultDisplay link hyperlink Target{..} = unHTML $ unwords $
+-- | Bool arguments decide whether links and colors are shown
+targetResultDisplay :: Bool -> Bool -> [Query] -> Target -> String
+targetResultDisplay link color qs Target{..} = unHTML $ unwords $
         map fst (maybeToList targetModule) ++
-        [if hyperlink then targetItemHyperlink else targetItem] ++
+        [if color then highlightFull targetItem else targetItem] ++
         ["-- " ++ targetURL | link]
      where
-        targetItemHyperlink = hyperlinkCode targetURL targetItem
+        highlightFull = hyperlinkCode targetURL . ansiHighlight qs
+
+ansiHighlight :: [Query] -> String -> String
+ansiHighlight = highlightItem id id ((dull ++) . (++ rst)) ((bold ++) . (++ rst))
+    where
+        dull = setSGRCode [SetColor Foreground Dull Yellow]
+        bold = setSGRCode [SetColor Foreground Vivid Yellow]
+        rst = setSGRCode []
 
 unHTMLtargetItem :: Target -> Target
 unHTMLtargetItem target = target {targetItem = unHTML $ targetItem target}

src/Action/Server.hs

@@ -255,23 +255,9 @@ showURL _ _ x = x
 -------------------------------------------------------------
 -- DISPLAY AN ITEM (bold keywords etc)
 
-highlightItem :: [Query] -> String -> Markup
-highlightItem qs x
-    | Just (pre,x) <- stripInfix "<s0>" x, Just (name,post) <- stripInfix "</s0>" x
-        = H.preEscapedString pre <> highlight (unescapeHTML name) <> H.preEscapedString post
-    | otherwise = H.string x
-    where
-        highlight = mconcatMap (\xs@((b,_):_) -> let s = H.string $ map snd xs in if b then H.b s else s) .
-                    groupOn fst . (\x -> zip (f x) x)
-            where
-              f (x:xs) | m > 0 = replicate m True ++ drop (m - 1) (f xs)
-                  where m = maximum $ 0 : [length y | QueryName y <- qs, lower y `isPrefixOf` lower (x:xs)]
-              f (x:xs) = False : f xs
-              f [] = []
 
 displayItem :: [Query] -> String -> Markup
-displayItem = highlightItem
-
+displayItem = highlightItem H.string H.preEscapedString H.string (H.b . H.string)
 
 action_server_test_ :: IO ()
 action_server_test_ = do

src/Input/Item.hs

@@ -4,7 +4,7 @@
 -- | Types used to generate the input.
 module Input.Item(
     Sig(..), Ctx(..), Ty(..), prettySig,
-    Item(..), itemName,
+    Item(..), itemName, highlightItem,
     Target(..), targetExpandURL, TargetId(..),
     splitIPackage, splitIModule,
     hseToSig, hseToItem, item_test,
@@ -31,6 +31,7 @@ import qualified Data.Aeson as J
 import Data.Aeson.Types
 import Test.QuickCheck
 import Distribution.Types.PackageName (unPackageName, mkPackageName)
+import Query
 
 ---------------------------------------------------------------------
 -- TYPES
@@ -197,6 +198,23 @@ item_test = testing "Input.Item.Target JSON (encode . decode = id) " $ do
     (Left  e ) -> False
     (Right t') -> t == t'
 
+highlightItem:: Monoid m => (String -> m) -> (String -> m) -> (String -> m) -> (String -> m) -> [Query] -> String -> m
+highlightItem plain safe dull bold qs x
+    | Just (pre,x) <- stripInfix "<s0>" x, Just (name,post) <- stripInfix "</s0>" x
+        = safe pre <> highlight (unescapeHTML name) <> safe post
+    | otherwise = plain x
+    where
+        highlight x = mconcatMap (\xs@((b,_):_) -> let s = map snd xs in if b then bold s else dull s) $
+                    groupOn fst $ zip (findQueries x) x
+            where
+                -- generates a bool mask, which is only true for charachters that compose given queries
+                -- e.g. [ "query" "ya" ] -> [ "AqUeRyAA" ] -> 01111110
+                findQueries :: String -> [Bool]
+                findQueries (x:xs) | m > 0 = replicate m True ++ drop (m - 1) (findQueries xs)
+                    where m = maximum $ 0 : [length y | QueryName y <- qs, lower y `isPrefixOf` lower (x:xs)]
+                findQueries (x:xs) = False : findQueries xs
+                findQueries [] = []
+
 ---------------------------------------------------------------------
 -- HSE CONVERSION