ureader-0.2.0.0: src/UReader/Rendering.hs
-- |
-- Copyright : (c) Sam Truzjan 2013
-- License : BSD3
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- This module provides colored (ansi-terminal compatible) rendering
-- for OPML, RSS, (Atom not yet) and HTML.
--
{-# OPTIONS -fno-warn-orphans #-}
module UReader.Rendering
( Order (..)
, Style (..)
, renderRSS
, renderFeedList
) where
import Control.Applicative
import Control.Monad
import Data.Char
import Data.Default
import Data.Function
import Data.Maybe
import Data.Monoid
import Data.List as L
import Data.List.Split as L
import Data.Set as S
import Text.HTML.TagSoup
import Text.OPML.Syntax
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>), width)
import Text.RSS.Syntax
import Text.XML.Light.Types
import Network.URI
import System.IO
import System.Console.Terminal.Size as Terminal
import UReader.RSS
import UReader.Localization
import UReader.Outline
{-----------------------------------------------------------------------
Feed list
-----------------------------------------------------------------------}
renderFeedList :: OPML -> IO ()
renderFeedList = print . pretty
instance Pretty Outline where
pretty Outline {..} =
fill 28 (topicTy (pretty opmlText))
<+> ppURI opmlOutlineAttrs <>
if L.null opmlOutlineChildren then mempty else linebreak <>
indent 4 (vsep $ L.map pretty opmlOutlineChildren)
-- , "type" <+> pretty opmlType
-- , "categories" <+> pretty opmlCategories
-- , "comment" <+> pretty opmlIsComment
-- , "breakpoint" <+> pretty opmlIsBreakpoint
-- , "other" <+> pretty (show opmlOutlineOther)
where
topicTy
| L.null opmlOutlineChildren = blue . underline
| otherwise = magenta . bold
ppURI (lookupAttr uriQName -> Just uriStr)
| Just uri <- parseURI uriStr = "<" <> text (show uri) <> ">"
| otherwise = red "invalid URL"
ppURI _ = mempty
instance Pretty OPMLHead where
pretty OPMLHead {..} = pretty opmlTitle
instance Pretty OPML where
pretty OPML {..}
= --"version" <+> text opmlVersion </>
--"head " <+> pretty opmlHead </>
vsep (L.map pretty opmlBody)
{-----------------------------------------------------------------------
Feed
-----------------------------------------------------------------------}
data Order = NewFirst
| OldFirst
deriving (Show, Read, Eq, Ord, Bounded, Enum)
data Style = Style
{ feedOrder :: !Order
, feedDesc :: !Bool
, feedMerge :: !Bool
, newOnly :: !Bool
} deriving (Show, Eq)
instance Default Style where
def = Style
{ feedOrder = NewFirst
, feedDesc = True
, feedMerge = False
, newOnly = False
}
prettyDesc :: Bool -> RSS -> Doc
prettyDesc keepDesc
| keepDesc = pretty
| otherwise
= vsep . punctuate linebreak . L.map pretty . rssItems . rssChannel
merge :: Bool -> [RSS] -> [RSS]
merge byTime
| byTime = return . mconcat
| otherwise = id
formatOrder :: Order -> RSS -> RSS
formatOrder NewFirst = id
formatOrder OldFirst = reverseItems
formatFeeds :: Style -> [RSS] -> Doc
formatFeeds Style {..}
= vsep . punctuate linebreak
. L.map (prettyDesc feedDesc . formatOrder feedOrder) . merge feedMerge
renderRSS :: Style -> [RSS] -> IO ()
renderRSS style feeds = do
Window {..} <- fromMaybe (Window 80 60) <$> Terminal.size
displayIO stdout $ renderPretty 0.8 width $ formatFeeds style feeds
instance Monoid RSS where
mempty = nullRSS "" ""
mappend a b = mempty
{ rssVersion = unwords $ S.toList $
mergeVersions (rssVersion a) (rssVersion b)
, rssAttrs = rssAttrs a <> rssAttrs b
, rssChannel = rssChannel a <> rssChannel b
, rssOther = rssOther a <> rssOther b
}
where
mergeVersions = (<>) `on` S.fromList . words
instance Monoid RSSChannel where
mempty = nullChannel "" ""
mappend a b = mempty
{ rssTitle = rssTitle a <> "|" <> rssTitle b
, rssLink = rssLink a <> " " <> rssLink b
, rssDescription = rssDescription a
, rssItems = mergeBy cmpPubDate (rssItems a) (rssItems b)
}
where
cmpPubDate = (>) `on` (parsePubDate <=< rssItemPubDate)
mergeBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
mergeBy _ [] xs = xs
mergeBy _ xs [] = xs
mergeBy f (x : xs) (y : ys)
| f x y = x : mergeBy f xs (y : ys)
| otherwise = y : mergeBy f (x : xs) ys
instance Pretty RSS where
pretty RSS {..} =
pretty rssChannel </>
dullblack ("rss version" <+> pretty rssVersion)
instance Pretty RSSChannel where
pretty RSSChannel {..} =
vcat (L.zipWith heading (splitOn "|" rssTitle) (words rssLink)) </>
pretty rssDescription </>
pretty rssPubDate <$$>
vcat (punctuate linebreak $ L.map pretty rssItems)
where
heading title link = blue (fill 24 (text title)) </> text link
instance Pretty RSSItem where
pretty RSSItem {..} =
(bold (magenta (pretty rssItemTitle)) </> pretty rssItemLink) <$$>
red (hsep $ L.map ppCategory rssItemCategories) <$$>
indent 2 (maybe mempty ppItemDesc rssItemDescription) <$$>
(maybe mempty ppComments rssItemComments) <$$>
(green (pretty rssItemGuid)) <$$>
(yellow (pretty rssItemPubDate) </>
maybe mempty ppAuthor rssItemAuthor)
where
ppItemDesc = nest 2 . prettySoup False False . extDesc
ppComments comments = "Comments: " <+> pretty comments
ppAuthor author = "posted by" <+> red (pretty author)
ppCategory category = dullblack "*" <> pretty category
instance Pretty RSSGuid where
pretty RSSGuid {..}
| Just True <- rssGuidPermanentURL = "Permalink:" <+> pretty rssGuidValue
| otherwise = "Link: " <+> pretty rssGuidValue
instance Pretty RSSCategory where
pretty RSSCategory {..} =
dullyellow (maybe mempty text rssCategoryDomain) <>
dullred (hsep $ L.map pretty rssCategoryAttrs) <>
dullblue (text rssCategoryValue)
instance Pretty Attr where
pretty Attr {..} = text (show attrKey) <+> "=" <+> text attrVal
extDesc :: String -> [Tag String]
extDesc = canonicalizeTags . parseTags
{- NOTE: the findCloseTag could lead to serious performance
degradation, but this is very unlikely for HTML embedded in RSS. -}
findCloseTag :: Eq a => a -> [Tag a] -> ([Tag a], [Tag a])
findCloseTag t = go (0 :: Int) []
where
go _ acc [] = (reverse acc, [])
go n acc (x : xs) =
case x of
TagOpen t' _
| t == t' -> go (succ n) (x : acc) xs
| otherwise -> go n (x : acc) xs
TagClose t'
| t == t' -> if n == 0
then (reverse acc, xs)
else go (pred n) (x : acc) xs
| otherwise -> go n (x : acc) xs
_ -> go n (x : acc) xs
prettySoup :: Bool -> Bool -> [Tag String] -> Doc
prettySoup _ _ [] = mempty
prettySoup upper raw (x : xs) = case x of
TagText t -> text (upperize (canonicalize t))
<> prettySoup upper raw xs
where
canonicalize | raw = id
| otherwise = L.filter isPrint
upperize | upper = L.map toUpper
| otherwise = id
TagOpen t attrs -> maybe err closeTag $ L.lookup t rules
where
rules =
[ "p" --> \par -> linebreak <> par <> linebreak
, "i" --> underline
, "em" --> underline
, "u" --> underline
, "strong" --> bold
, "b" --> bold
, "tt" --> dullwhite
, "hr" --> \body -> body <> linebreak <>
underline (text (L.replicate 72 ' ')) <> linebreak
, "a" --> \desc -> blue desc </> pretty (L.lookup "href" attrs)
, "br" --> (linebreak <>)
, "ul" --> id
, "li" --> \li -> green "*" <+> li <> linebreak
, "span" --> id
, "code" ~-> (onwhite . black)
, "img" --> \desc -> blue desc </> pretty (L.lookup "src" attrs)
, "pre" ~-> \body -> linebreak <> align body <> linebreak
, "h1" ==> heading
, "h2" --> heading
, "h3" --> heading
, "h4" --> heading
, "h5" --> heading
, "h6" --> heading
, "div" --> \body -> linebreak <> body <> linebreak
, "blockquote" --> indent 4
, "table" --> \body -> linebreak <> body <> linebreak
, "tbody" --> id
, "tr" --> \body -> linebreak <> body <> linebreak
, "td" --> fill 40
]
where
a --> f = (a, f . prettySoup False False)
a ~-> f = (a, f . prettySoup False True)
a ==> f = (a, f . prettySoup True False)
heading body = linebreak <> bold (underline body) <> linebreak
err = red ("<" <> text t <+> def_attrs <> ">")
<+> prettySoup upper raw xs
where
def_attrs = hcat $ punctuate space $ L.map pattr attrs
where pattr (n, v) = text n <> "=" <> text v
closeTag m = m a <> prettySoup upper raw b
where
(a, b) = findCloseTag t xs
TagClose t -> red ("</" <> text t <> ">") <+> prettySoup upper raw xs
t -> text (show t) <> prettySoup upper raw xs