-- | Converting markup to HTML
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],
    -- | If set, all relative URIs will be resolved with this as a base.
    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 = [
                         -- chunk formats
                         preChunk, 
                         quoteChunk,
                         -- reference formats
                         imageRef
                        ]

--
-- * Chunk formatters
--

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

--
-- * Ref formatters
--

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]  

--
-- * XHtml generation
--

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 -- FIXME: what should we do here?
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


--
-- * Generating plain text.
--

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 = " "