module Text.HMarkup.XHtml (docToHtml,
MarkupXHtmlPrefs(..),
MarkupXHtmlFormat(..),
standardMarkupFormats,
defaultMarkupXHtmlPrefs,
markupURL, markupURI,
useChunkFormat, useRefFormat) where
import Text.HMarkup.Parse
import Text.HMarkup.Types
import Control.Monad
import Data.List
import Data.Maybe
import Network.URI
import Text.XHtml
data MarkupXHtmlPrefs m = MarkupXHtmlPrefs {
markupFormats :: [MarkupXHtmlFormat m],
markupBaseURI :: Maybe URI
}
data MarkupXHtmlFormat m =
ChunkFormat {
formatName :: String,
formatChunk :: MarkupXHtmlPrefs m -> String -> m Html
}
| RefFormat {
formatName :: String,
formatRef :: MarkupXHtmlPrefs m -> URI -> [Text] -> m Html
}
defaultMarkupXHtmlPrefs :: Monad m => MarkupXHtmlPrefs m
defaultMarkupXHtmlPrefs =
MarkupXHtmlPrefs {
markupFormats = standardMarkupFormats,
markupBaseURI = Nothing
}
standardMarkupFormats :: Monad m => [MarkupXHtmlFormat m]
standardMarkupFormats = [
preChunk,
quoteChunk,
imageRef
]
defaultChunkFormat :: Monad m => MarkupXHtmlFormat m
defaultChunkFormat = preChunk
preChunk :: Monad m => MarkupXHtmlFormat m
preChunk = ChunkFormat "pre" f
where f _ s = return $ pre << s
quoteChunk :: Monad m => MarkupXHtmlFormat m
quoteChunk = ChunkFormat "quote" f
where f pref = liftM (blockquote <<) . toHtmlOrPlain pref
defaultRefFormat :: Monad m => MarkupXHtmlFormat m
defaultRefFormat = RefFormat "link" f
where
f pref uri ts =
liftM (anchor ! [href (markupURL pref uri)] <<)
(textsToHtml pref ts')
where ts' = if null ts then [Word (show uri)] else ts
imageRef :: Monad m => MarkupXHtmlFormat m
imageRef = RefFormat "image" f
where
f pref uri ts =
do let tit = textsToPlain ts
url = case parseURIReference (uriPath uri) of
Nothing -> show uri
Just u -> markupURL pref u
return $ image ! [src url, alt tit]
docToHtml :: Monad m =>
MarkupXHtmlPrefs m -> Doc -> m Html
docToHtml pref (Doc ps) = liftM concatHtml (mapM (blockToHtml pref) ps)
blockToHtml :: Monad m => MarkupXHtmlPrefs m -> Block -> m Html
blockToHtml pref (Chunk n s) = useChunkFormat pref n s
blockToHtml pref (Header n ts) = liftM (h <<) (textsToHtml pref ts)
where h = case n of
_ | n < 1 -> error $ "Header " ++ show n
1 -> h1
2 -> h2
3 -> h3
4 -> h4
5 -> h5
6 -> h6
_ -> h6
blockToHtml pref (Para ts) = liftM (paragraph <<) (textsToHtml pref ts)
blockToHtml pref (ItemList tss) = liftM unordList $ mapM (textsToHtml pref) tss
textsToHtml :: Monad m => MarkupXHtmlPrefs m -> [Text] -> m Html
textsToHtml pref = liftM concatHtml . mapM (textToHtml pref)
textToHtml :: Monad m => MarkupXHtmlPrefs m -> Text -> m Html
textToHtml pref (Emph ts) = liftM (emphasize <<) (textsToHtml pref ts)
textToHtml pref (TT ts) = liftM (tt <<) (textsToHtml pref ts)
textToHtml pref (Ref uri ts) = useRefFormat pref n uri ts
where n = removeTrailing (uriScheme uri) ':'
textToHtml _ (Word t) = return $ toHtml t
textToHtml _ WhiteSpace = return $ toHtml " "
markupURI :: Monad m => MarkupXHtmlPrefs m -> URI -> URI
markupURI pref uri = case markupBaseURI pref of
Nothing -> uri
Just baseURI -> uri `relativeTo'` baseURI
where relativeTo' x y =
fromMaybe (error $ "relativeTo " ++ show x ++ " " ++ show y)
(x `relativeTo` y)
markupURL :: Monad m => MarkupXHtmlPrefs m -> URI -> URL
markupURL pref = show . markupURI pref
removeTrailing :: Eq a => [a] -> a -> [a]
removeTrailing xs x = reverse $ dropWhile (==x) $ reverse xs
toHtmlOrPlain :: Monad m =>
MarkupXHtmlPrefs m -> String -> m Html
toHtmlOrPlain pref s =
case parseMarkup "<input>" s of
Nothing -> return $ toHtml s
Just x -> docToHtml pref x
useChunkFormat :: Monad m => MarkupXHtmlPrefs m -> String -> String -> m Html
useChunkFormat pref n s =
do x <- case [f | f@(ChunkFormat n' _) <- markupFormats pref, n' == n] of
[] -> return defaultChunkFormat
[y] -> return y
_ -> fail $ "More than one chunk format called " ++ n
liftM (thediv ! [theclass ("chunk-"++n)] <<) $ formatChunk x pref s
useRefFormat :: Monad m =>
MarkupXHtmlPrefs m -> String -> URI -> [Text] -> m Html
useRefFormat pref n uri ts =
do x <- case [f | f@(RefFormat n' _) <- markupFormats pref, n' == n] of
[] -> return defaultRefFormat
[y] -> return y
_ -> fail $ "More than one ref format called " ++ n
liftM (thespan ! [theclass ("ref-"++n)] <<) $ formatRef x pref uri ts
textsToPlain :: [Text] -> String
textsToPlain = concat . map textToPlain
textToPlain :: Text -> String
textToPlain (Emph ts) = "*" ++ textsToPlain ts ++ "*"
textToPlain (TT ts) = "``" ++ textsToPlain ts ++ "``"
textToPlain (Ref uri ts) = "[" ++ show uri ++ " " ++ textsToPlain ts ++ "]"
textToPlain (Word t) = t
textToPlain WhiteSpace = " "