{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module Kevin.Util.Tablump (
tablumpDecode
) where
import Text.Regex.PCRE
import Text.Regex.PCRE.String
import Text.Printf
import Control.Arrow
import Control.Monad.Fix
import System.IO.Unsafe
import qualified Data.Text as T
fromRight :: (Show a) => Either a b -> b
fromRight (Left x) = error $ "fromRight on Left " ++ show x
fromRight (Right a) = a
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)
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\t" $$ const "",
"&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 "",
"&/abbr\t" $$ const "",
"&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 "" x y z,
"&iframe\t(.+?)\t(.*?)\t(.*?)\t" $$ \(x:y:z:_) -> printf "" x y z,
"&acro\t(.+?)\t" $$ \(x:_) -> printf "" x,
"&abbr\t(.+?)\t" $$ \(x:_) -> printf "" x,
" " $$ const "",
"^.+?:" $$ \(x:_) -> printf "%s:" x,
"^[a-zA-Z0-9\\-_]+:" $$ \(x:_) -> printf "%s:" x
]
tablumpDecode :: T.Text -> T.Text
tablumpDecode = T.pack . flip (foldr (uncurry regexReplace)) regexen . T.unpack