I'm a Haskell beginner, and I wanted to make a color annotator or color highlighter, one which takes a text as standard input, and outputs that text, with its color words highlighted using the colors themselves. So, it should replace all instances of the word "red" in a text with <span class="color" style="color: #ff0000">red</span>.

I'm using the color map from XKCD, here, which is also discussed in this blog post.

The packages I'm using are lucid replace-attoparsec cabal-install optparse-generic text, so I think you can run this file with something like stack runhaskell ThisFile.hs --package attoparsec replace-attoparsec text optparse-generic.

The main problem I'm aware of is that the output of the parser is the parsed string, not the string used to generate the parser. So that means I have to look up the color again, which means it's really slow, and it doesn't find all of them. I don't really know of the best way to fix that.

Edit: a few gotchas that make this problem hard for me:

  • I can rewrite this to run lots of little parsers over the whole text, but the problem there is with re-parsing the same text. For instance, I don't want to end up with nested replacements, like <span ...>light blue <span ...>green</span></span>.
  • Running one big parser, with choice, seems to fix the issue of overlapping parses, but then I don't seem to have access to the expression that generated the parser, and its associated hex code.
{-# LANGUAGE OverloadedStrings #-}

module AnnotateColor where

import Data.List (intersperse, sort, sortBy)
import Lucid
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.IO as TIO
import Data.Function (on)
import Replace.Attoparsec.Text
import Data.Attoparsec.Text as AT
import qualified Data.Text as T
import Data.Either
import Data.Char
import qualified Data.Map.Strict as M
import Control.Applicative ((<|>), empty)
import Options.Generic

-- | Just some useful aliases here
type ColorWord = T.Text
type Hex = T.Text

wordBoundary :: Parser Char
wordBoundary = satisfy (inClass " \n\r\"\'")

-- | Takes a list of words like "light green blue" and makes a
-- parser which will find "light green blue" and also "light green-blue",
-- "light green\nblue" and so on.
wordListParser :: [T.Text] -> Parser T.Text
wordListParser [w] = do -- One word case
  boundaryBefore <- wordBoundary
  word <- asciiCI w
  boundaryAfter <- wordBoundary
  return word
wordListParser (w:ws) = do  -- Multi-word case
  satisfy (inClass " \n\r\"\'")  -- Word boundary first
  a <- asciiCI w                  -- word, case insensitive
  b <- satisfy (inClass " -\n\r") -- a separator
  c <- wordListParser ws          -- more words
  return (a `T.append` (T.singleton b) `T.append` c) -- singleton :: Char -> Text

-- | Make one big parser out of our color map, and the expressions
-- generated from wordListParser.
colorParser :: [(ColorWord, Hex)] -> Parser T.Text
colorParser colormap = choice $ map (wordListParser . T.words . fst) $ colormap

-- | Makes HTML from a color word and hex pair.
-- I.e. "red" -> "<span class="color" style="color: #ff0000">"
makeSpan :: T.Text -> T.Text -> TL.Text
makeSpan colorWord hex = TL.concat [" ", t, " "] where
  t = renderText $ span_ attrs (toHtml colorWord)
  attrs = [ class_ "color", style_ (T.concat ["color: ", hex])::Attribute ]

-- | Maps a function across both items in a tuple
mapTuple :: (a -> b) -> (a, a) -> (b, b)
mapTuple f (a1, a2) = (f a1, f a2)

-- | Processes the plain text (TSV) color map from XKCD,
-- and converts it to the list of tuples we'll be using for
-- a color map. 
xkcdMap :: T.Text -> [(T.Text, T.Text)]
xkcdMap rawMap = reverse $ sortBy (compare `on` T.length . fst) unsorted
    textLines = tail $ T.lines rawMap
    unsorted = [ mapTuple T.strip ( T.breakOn "\t" ln ) | ln <- textLines ]

-- | The parser returns what it parsed, which may or may not contain
-- hyphens. But we want the non-hyphenated version so that we can
-- look up its hex in the color map. It sucks that we have to
-- look up the hex code again, but I can't think of a better way.
-- So this cleans up the color expression as found by the parser,
-- so that it can be used by the lookup.
punctToSpace :: T.Text -> T.Text
punctToSpace str = T.map p2s str where
  p2s = (\c -> if T.isInfixOf (T.singleton c) "-\n\r" then ' ' else c)

-- | Using a map-ified version of our color map, this looks
-- up each word found by the parser, and if found, turns it
-- into HTML, highlighting it using its color. 
annotate :: M.Map ColorWord Hex -> T.Text -> T.Text
annotate cmm color = case cmm M.!? ((punctToSpace . T.strip) color) of
  Nothing -> (T.concat ["CANTFIND", color])
  Just hex -> TL.toStrict $ makeSpan (T.strip color) hex

main :: IO ()
main = do
    -- Load color map. (Data from https://xkcd.com/color/rgb.txt )
    rawText <- TIO.readFile "../data/xkcd/rgb.txt"
    -- Process color map
    let cm = xkcdMap rawText
    -- Make Data.Map map out of it
    let cmm = M.fromList cm
    -- Parse command-line argument, and read the filename given
    -- by the first argument.
    fileName <- getRecord "Color word annotator."
    inFile <- TIO.readFile fileName
    -- Run the parser, annotate it, print the results.
    TIO.putStr $ streamEdit (colorParser cm) (annotate cmm) inFile

I'm also beginner, so not sure if can make a good review, but just want to notice. If you just need to replace a bunch of string (the list of colors), maybe it's better to use Aho-Corasick algorithm to find all matches and then just use fold through all matches. I did it for similar task.
I used this implementation:
As I remember, I had some issues and made changes in this library to make it working with the current GHC version, but these were very simple changes.
But it will be very interesting for me to read answers.

P.S. I remembered what was the problem and how I "solve" it. I just used this commit from this fork:
Someone already fixed the issue. So just add in stack.yaml

  - github: stackbuilders/AhoCorasick
    commit: 9a825aef5d19c707d2306befca688a1a72d50bb0
| improve this answer | |
  • 1
    \$\begingroup\$ That's a cool looking algorithm, but is there a way to get it to work for non-overlapping matches? \$\endgroup\$ – Jonathan Feb 10 at 1:22
  • \$\begingroup\$ You can always decide what to do. You have position and length. So just skip all next matches before match position become more then old match position + old match length. Surely it's more difficult in case you have strings to search like a b and b c and text like a b c. But for such case you have the same problem for any algorithm. For any other cases it's easy to define what to do. And yes, from Aho-Corasick algorithm you have matches "sorted" by position. So if you don't have partially overlapped search terms, longest match will be always first. \$\endgroup\$ – Dima Kurilo Feb 10 at 1:43
  • \$\begingroup\$ Sorry, I have error, matches are sorted by position, but if you have dark and dark green you can have match with dark first. So, you need to do something about it. \$\endgroup\$ – Dima Kurilo Feb 10 at 2:44
  • \$\begingroup\$ @Jonathan, sorry, looks like my case wasn't the same as your. I had finished HTML parts that I was need to replace with other. With open and close tag and so on. But in your case you can have word blues and so on. I tried to implement what you need with Aho-Corasick and not sure if it's faster then your approach with parser. It's possible to optimize it, but it will be to difficult to read then. Here is what I tried: gist.github.com/DKurilo/611d736cfb76947a5684a8c8470967b9 You would also need to add all possible colors like dark-blue. Parser is better here. \$\endgroup\$ – Dima Kurilo Feb 10 at 4:25
  • \$\begingroup\$ Nice. I really want to try that out, but I don't use stack, and I'm having trouble making a shell.nix file for it. Or any file that gets it to compile, actually. Here's the latest thing I tried: stackoverflow.com/questions/60161518/… \$\endgroup\$ – Jonathan Feb 11 at 6:46

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.