{-# LANGUAGE DeriveDataTypeable #-}
-- | A module representing strings with formatting.
module Hoogle.Type.TagStr(
TagStr(..),
showTagText, showTagANSI,
showTagHTML, showTagHTMLWith,
formatTags
) where
import General.Base
import General.Web
import Data.Generics.Uniplate
import Data.Binary.Defer
data TagStr
= Str String -- ^ Plain text.
| Tags [TagStr] -- ^ A list of tags one after another.
| TagBold TagStr -- ^ Bold text.
| TagEmph TagStr -- ^ Underlined/italic text.
| TagLink String TagStr -- ^ A hyperlink to a URL.
| TagColor Int TagStr -- ^ Colored text. Index into a 0-based palette. Text without any 'TagColor' should be black.
deriving (Data,Typeable,Ord,Show,Eq)
instance Monoid TagStr where
mempty = Str ""
mappend x y = Tags [x,y]
mconcat = Tags
instance Uniplate TagStr where
uniplate (Tags xs) = (xs, Tags)
uniplate (TagBold x) = ([x], \[x] -> TagBold x)
uniplate (TagEmph x) = ([x], \[x] -> TagEmph x)
uniplate (TagLink i x) = ([x], \[x] -> TagLink i x)
uniplate (TagColor i x) = ([x], \[x] -> TagColor i x)
uniplate x = ([], const x)
instance BinaryDefer TagStr where
put (Str x) = putByte 0 >> put1 x
put (Tags x) = putByte 1 >> put1 x
put (TagBold x) = putByte 2 >> put1 x
put (TagEmph x) = putByte 3 >> put1 x
put (TagLink x y) = putByte 4 >> put2 x y
put (TagColor x y) = putByte 5 >> put2 x y
get = do i <- getByte
case i of
0 -> get1 Str
1 -> get1 Tags
2 -> get1 TagBold
3 -> get1 TagEmph
4 -> get2 TagLink
5 -> get2 TagColor
{-
instance BD.BinaryDefer TagStr where
put x = BD.putLazyByteString $ encode x
get = fmap decode BD.getLazyByteString
instance Binary TagStr where
put (Str x) = putWord8 0 >> put x
put (Tags x) = putWord8 1 >> put x
put (TagBold x) = putWord8 2 >> put x
put (TagEmph x) = putWord8 3 >> put x
put (TagLink x y) = putWord8 4 >> put x >> put y
put (TagColor x y) = putWord8 5 >> put x >> put y
get = do i <- getWord8
case i of
0 -> fmap Str get
1 -> fmap Tags get
2 -> fmap TagBold get
3 -> fmap TagEmph get
4 -> fmap TagLink get get
5 -> fmap TagColor get get
-}
-- | Show a 'TagStr' as a string, without any formatting.
showTagText :: TagStr -> String
showTagText x = concat [y | Str y <- universe x]
-- | Show a 'TagStr' on a console with ANSI escape sequences.
showTagANSI :: TagStr -> String
showTagANSI x = f [] x
where
f a (Str x) = x
f a t =
case getCode t of
Nothing -> g a
Just val -> tag (val:a) ++ g (val:a) ++ tag a
where g a = concatMap (f a) (children t)
getCode (TagBold _) = Just "1"
getCode (TagLink url _) = if null url then Nothing else Just "4"
getCode (TagEmph _) = Just "4"
getCode (TagColor n _) | n <= 5 && n >= 0 = Just ['3', intToDigit (n + 1)]
getCode _ = Nothing
tag stack = chr 27 : '[' : intercalate ";" ("0":reverse stack) ++ "m"
-- | Show a 'TagStr' as HTML, using CSS classes for color styling.
showTagHTML :: TagStr -> String
showTagHTML = showTagHTMLWith (const Nothing)
-- | Show TagStr with an override for specific tags.
showTagHTMLWith :: (TagStr -> Maybe String) -> TagStr -> String
showTagHTMLWith f x = g x
where
g x | isJust (f x) = fromJust $ f x
g (Str x) = nbsp $ escapeHTML x
g (Tags xs) = concatMap g xs
g (TagBold x) = htmlTag "b" $ showTagHTML x
g (TagEmph x) = htmlTag "i" $ showTagHTML x
g (TagLink url x) = "" ++ showTagHTML x ++ ""
g (TagColor i x) = "" ++ showTagHTML x ++ ""
nbsp (' ':' ':xs) = " " ++ nbsp xs
nbsp (x:xs) = x : nbsp xs
nbsp [] = []
-- each position is a 0-based start and end index
-- currently not allowed to overlap
formatTags :: String -> [((Int,Int),TagStr -> TagStr)] -> TagStr
formatTags o y = tags $ f o 0 $ sortBy (comparing $ fst . fst) y
where
f x i [] = str x
f x i (((from,to),op):ss)
| i > from = error $ "TagStr.formatTags, not allowed overlapping formats on: " ++ o
| otherwise = str a ++ [op $ Str c] ++ f d to ss
where (a,b) = splitAt (from-i) x
(c,d) = splitAt (to-from) b
tags [] = Str ""
tags [x] = x
tags xs = Tags xs
str x = [Str x | x /= ""]