Util.hs

{-# OPTIONS_GHC -fno-warn-tabs #-}
{-# LANGUAGE TupleSections, OverloadedStrings, ViewPatterns #-}

module Util (
	mconcat, (.), (++), Text, replace, xml, spanTag, h, getDigit, startsWith, urlChars,
	anchor, Anchor(..), writeFile, readFile, greekAlphabet, mapLast, mapHead, stripInfix, dropTrailingWs,
	textStripInfix, textSubRegex, splitOn, intercalateBuilders, replaceXmlChars, stripAnyPrefix, trimString,
	spanJust, measure, partitionBy
	) where

import Prelude hiding ((.), (++), writeFile)
import qualified Data.Text as Text
import qualified Data.Map as Map
import Data.List (stripPrefix, intersperse)
import Data.Char (ord, isDigit, isSpace)
import Data.Text (Text, replace)
import Data.Text.IO (writeFile)
import Data.Time (getCurrentTime, diffUTCTime)
import Control.Arrow (first)
import Text.Regex (subRegex, Regex)
import qualified Data.Text.Lazy.Builder as TextBuilder

(.) :: Functor f => (a -> b) -> (f a -> f b)
(.) = fmap

(++) :: Monoid a => a -> a -> a
(++) = mappend

xml :: Text -> [(Text, Text)] -> TextBuilder.Builder -> TextBuilder.Builder
xml t attrs = (TextBuilder.fromText ("<" ++ t ++ " " ++ Text.unwords (map f attrs) ++ ">") ++) . (++ TextBuilder.fromText ("</" ++ t ++ ">"))
	where
		f (n, v) = n ++ "='" ++ v ++ "'"

spanTag :: Text -> TextBuilder.Builder -> TextBuilder.Builder
spanTag = xml "span" . (:[]) . ("class",)

h :: Int -> TextBuilder.Builder -> TextBuilder.Builder
h = flip xml [] . ("h" ++) . Text.pack . show

data Anchor = Anchor
    { aClass, aId, aHref :: Text
    , aText :: TextBuilder.Builder
    , aStyle, aTitle :: Text }

intercalateBuilders :: TextBuilder.Builder -> [TextBuilder.Builder] -> TextBuilder.Builder
intercalateBuilders x y = mconcat $ intersperse x y

anchor :: Anchor
anchor = Anchor{aClass="", aId="", aHref="", aText=TextBuilder.fromText "", aStyle="", aTitle=""}

greekAlphabet :: [(String, Char)]
greekAlphabet =
	[ ("alpha"          , 'α')
	, ("beta"           , 'β')
	, ("gamma"          , 'γ')
	, ("delta"          , 'δ')
	, ("mu"             , 'μ')
	, ("nu"             , 'ν')
	, ("lambda"         , 'λ')
	, ("pi"             , 'π')
	, ("phi"            , 'φ')
	, ("rho"            , 'ρ')
	, ("sigma"          , 'σ')
	, ("theta"          , 'θ')
	, ("zeta"           , 'ζ')

	, ("Gamma"          , 'Γ')
	, ("Pi"             , 'Π') ]

mapLast :: (a -> a) -> [a] -> [a]
mapLast _ [] = []
mapLast f [x] = [f x]
mapLast f (x:xx) = x : mapLast f xx

mapHead :: (a -> a) -> [a] -> [a]
mapHead f (x:y) = f x : y
mapHead _ [] = []

getDigit :: Char -> Maybe Int
getDigit c
	| isDigit c = Just $ ord c - ord '0'
	| otherwise = Nothing

stripInfix :: Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix p s | Just r <- stripPrefix p s = Just ([], r)
stripInfix p (hd:t) = first (hd:) . stripInfix p t
stripInfix _ _  = Nothing

textStripInfix :: Text -> Text -> Maybe (Text, Text)
textStripInfix inf (Text.breakOn inf -> (a, b))
	| b == "" = Nothing
	| otherwise = Just (a, Text.drop (Text.length inf) b)

startsWith :: (Char -> Bool) -> (Text -> Bool)
startsWith _ "" = False
startsWith p t = p (Text.head t)

dropTrailingWs :: String -> String
dropTrailingWs = reverse . dropWhile isSpace . reverse

urlChars :: Text -> Text
urlChars =
	replace "'"  "&#39;" .
	replace "<"  "%3c" .
	replace ">"  "%3e" .
	replace "\"" "%22" .
	replace "#"  "%23" .
	replace "{"  "%7b" .
	replace "|"  "%7c" .
	replace "}"  "%7d" .
	replace "["  "%5b" .
	replace "\\" "%5c" .
	replace "]"  "%5d" .
	replace "^"  "%5e" .
	replace " "  "%20" .
	replace "%"  "%25"

textSubRegex :: Regex -> String -> Text -> Text
textSubRegex pat repl txt = Text.pack $ subRegex pat (Text.unpack txt) repl

splitOn :: (a -> Bool) -> [a] -> [[a]]
splitOn _ [] = [[]]
splitOn sep (x:y)
    | sep x = [] : splitOn sep y
    | otherwise = mapHead (x :) $ splitOn sep y

replaceXmlChars :: Text -> Text
replaceXmlChars =
	replace ">" "&gt;" .
	replace "<" "&lt;" .
	replace "&" "&amp;"

stripAnyPrefix :: [Text] -> Text -> Maybe (Text, Text)
stripAnyPrefix [] _ = Nothing
stripAnyPrefix (x:y) z
    | Just a <- Text.stripPrefix x z = Just (x, a)
    | otherwise = stripAnyPrefix y z

trimString :: String -> String
trimString = reverse . dropWhile isSpace . reverse . dropWhile isSpace

spanJust :: [a] -> (a -> Maybe b) -> ([b], [a])
spanJust (x : z) f
    | Just y <- f x = first (y :) (spanJust z f)
spanJust z _ = ([], z)

measure :: IO a -> IO (a, Float)
measure f = do
	start <- getCurrentTime
	r <- f
	end <- getCurrentTime
	return (r, realToFrac $ diffUTCTime end start)

partitionBy :: (Ord b, Eq b) => (a -> b) -> [a] -> [(b, [a])]
partitionBy f l = Map.assocs $ Map.fromListWith (flip (++)) [(f x, [x]) | x <- l]