Tablump.hs

{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module Kevin.Util.Tablump (
    tablumpDecode
) where

import Control.Arrow
import Control.Monad.Fix
import qualified Data.Text as T
import System.IO.Unsafe
import Text.Printf
import Text.Regex.PCRE
import Text.Regex.PCRE.String

fromRight :: (Show a) => Either a b -> b
fromRight (Left x) = error $ "fromRight on Left " ++ show x
fromRight (Right a) = a

{-# NOINLINE regexReplace #-}
regexReplace :: Regex -> ([String] -> String) -> String -> String
regexReplace find replace = fix (\f str -> case fromRight . unsafePerformIO $ regexec find str of
    Just (bef, _, af, matches) -> concat [bef, replace matches, f af]
    Nothing -> str)

{-# NOINLINE regexen #-}
regexen :: [(Regex, [String] -> String)]
regexen = let ($$) = (,) in map (first (fromRight . unsafePerformIO . compile defaultCompOpt defaultExecOpt)) . reverse $ [
        "&b\t"      $$ const "\2",
        "&/b\t"     $$ const "\15",
        "&i\t"      $$ const "\22",
        "&/i\t"     $$ const "\15",
        "&u\t"      $$ const "\31",
        "&/u\t"     $$ const "\15",
        "&s\t"      $$ const "<s>",
        "&/s\t"     $$ const "</s>",
        "&sup\t"    $$ const "",
        "&/sup\t"   $$ const "",
        "&sub\t"    $$ const "",
        "&/sub\t"   $$ const "",
        "&code\t"   $$ const "",
        "&/code\t"  $$ const "",
        "&br\t"     $$ const "\n",
        "&ul\t"     $$ const "",
        "&/ul\t"    $$ const "",
        "&ol\t"     $$ const "",
        "&/ol\t"    $$ const "",
        "&li\t"     $$ const "- ",
        "&/li\t"    $$ const "\n",
        "&bcode\t"  $$ const "",
        "&/bcode\t" $$ const "",
        "&/a\t"     $$ const ")",
        "&/acro\t"  $$ const "</acronym>",
        "&/abbr\t"  $$ const "</abbr>",
        "&p\t"      $$ const "",
        "&/p\t"     $$ const "\n",
        "&emote\t(.+?)\t.+?\t.+?\t.+?\t.+?\t" $$ head,
        "&a\t(.+?)\t.*?\t" $$ \(x:_) -> printf "%s (" x,
        "&link\t(.+?)\t&\t" $$ head,
        "&link\t(.+?)\t(.+?)\t&\t" $$ \(x:y:_) -> printf "%s (%s)" x y,
        "&dev\t.+?\t(.+?)\t" $$ head,
        "&avatar\t(.+?)\t.+?\t" $$ \(x:_) -> printf ":icon%s:" x,
        "&thumb\t(.+?)\t.+?\t.+?\t.+?\t.+?\t.+?\t.+?\t" $$ \(x:_) -> printf ":thumb%s:" x,
        "&img\t(.+?)\t(.*?)\t(.*?)\t" $$ \(x:y:z:_) -> printf "<img src='%s' alt='%s' title='%s' />" x y z,
        "&iframe\t(.+?)\t(.*?)\t(.*?)\t" $$ \(x:y:z:_) -> printf "<iframe src='%s' width='%s' height='%s' />" x y z,
        "&acro\t(.+?)\t" $$ \(x:_) -> printf "<acronym title='%s'>" x,
        "&abbr\t(.+?)\t" $$ \(x:_) -> printf "<abbr title='%s'>" x,
        " ?<abbr title='colors:[0-9A-Fa-f]{6}:[0-9A-Fa-f]{6}'></abbr>" $$ const "",
        "^<abbr title='(.+?)'>.+?</abbr>:" $$ \(x:_) -> printf "%s:" x,
        "^[a-zA-Z0-9\\-_]+<abbr title='(.+?)'></abbr>:" $$ \(x:_) -> printf "%s:" x
    ]

tablumpDecode :: T.Text -> T.Text
tablumpDecode = T.pack . flip (foldr (uncurry regexReplace)) regexen . T.unpack