module Rakka.Wiki.Formatter ( formatWikiBlocks ) where import Control.Arrow import Control.Arrow.ArrowIf import Control.Arrow.ArrowList import Control.Arrow.ArrowTree import Data.Char import Data.List import Data.Maybe import Network.URI hiding (fragment) import Rakka.Page import Rakka.Wiki import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.DOM.TypeDefs formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree formatWikiBlocks = proc (baseURI, blocks) -> do block <- arrL id -< blocks tree <- formatBlock -< (baseURI, block) attachXHtmlNS -< tree formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree formatElement = proc (baseURI, e) -> case e of Block b -> formatBlock -< (baseURI, b) Inline i -> formatInline -< (baseURI, i) formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree formatBlock = proc (baseURI, block) -> case block of Heading level text -> formatHeading -< (level, text) HorizontalLine -> eelem "hr" -< () list@(List _ _) -> formatListElement -< (baseURI, list) DefinitionList list -> formatDefinitionList -< (baseURI, list) Preformatted inlines -> formatPreformatted -< (baseURI, inlines) Paragraph inlines -> formatParagraph -< (baseURI, inlines) Div attrs contents -> formatElem "div" -< (baseURI, attrs, contents) EmptyBlock -> none -< () _ -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block where formatElem :: (ArrowXml a, ArrowChoice a) => String -> a (URI, [Attribute], [Element]) XmlTree formatElem name = proc (baseURI, attrs, contents) -> ( eelem name += ( arrL (fst . snd) >>> attrFromPair ) += ( (arr fst &&& arrL (snd . snd)) >>> formatElement ) ) -< (baseURI, (attrs, contents)) formatHeading :: ArrowXml a => a (Int, String) XmlTree formatHeading = proc (level, text) -> mkelem ("h" ++ show level) [ sattr "id" text ] [ txt text ] -<< () formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree formatListElement = proc (baseURI, list) -> let tag = case listType list of Bullet -> "ul" Numbered -> "ol" in ( eelem tag += ( (constA baseURI &&& constL (listItems list)) >>> formatListItem ) ) -<< () where formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree formatListItem = proc (baseURI, item) -> eelem "li" += ( (arr fst &&& arrL snd) >>> formatElement ) -< (baseURI, item) formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree formatDefinitionList = proc (baseURI, list) -> ( eelem "dl" += ( (arr fst &&& arrL snd) >>> formatDefinition ) ) -< (baseURI, list) where formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree formatDefinition = proc (baseURI, def) -> ( eelem "dt" += ( (arr fst &&& arrL (defTerm . snd)) >>> formatInline ) <+> eelem "dd" += ( (arr fst &&& arrL (defDesc . snd)) >>> formatInline ) ) -< (baseURI, def) formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree formatPreformatted = eelem "pre" += ( (arr fst &&& arrL snd) >>> formatInline ) formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree formatParagraph = eelem "p" += ( (arr fst &&& arrL snd) >>> formatInline ) formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree formatInline = proc (baseURI, i) -> case i of Text text -> mkText -< text Italic contents -> formatElem "i" -< (baseURI, [], contents) Bold contents -> formatElem "b" -< (baseURI, [], contents) link@(ObjectLink _ _) -> formatObjectLink -< (baseURI, link) link@(PageLink _ _ _) -> formatPageLink -< (baseURI, link) link@(ExternalLink _ _) -> formatExternalLink -< link LineBreak attrs -> formatElem "br" -< (baseURI, attrs, []) Span attrs contents -> formatElem "span" -< (baseURI, attrs, contents) img@(Image _ _) -> formatImage -< (baseURI, img) Anchor attrs contents -> formatElem "a" -< (baseURI, attrs, contents) Input attrs -> formatElem "input" -< (baseURI, attrs, []) EmptyInline -> none -< () _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i where formatElem :: (ArrowXml a, ArrowChoice a) => String -> a (URI, [Attribute], [InlineElement]) XmlTree formatElem name = proc (baseURI, attrs, contents) -> ( eelem name += ( arrL (fst . snd) >>> attrFromPair ) += ( (arr fst &&& arrL (snd . snd)) >>> formatInline ) ) -< (baseURI, (attrs, contents)) attrFromPair :: (ArrowXml a) => a (String, String) XmlTree attrFromPair = proc (name, value) -> attr name (txt value) -<< () formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree formatObjectLink = proc (baseURI, ObjectLink page text) -> let uri = mkObjectURI baseURI page href = uriToString id uri "" label = fromMaybe ("{" ++ page ++ "}") text in mkAnchor -< (href, label) formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree formatPageLink = proc (baseURI, PageLink page fragment text) -> let uri = case (page, fragment) of (Just x, Just y) -> mkPageFragmentURI baseURI x y (Just x, Nothing) -> mkPageURI baseURI x (Nothing, Just y) -> mkFragmentURI y _ -> undefined href = uriToString id uri "" dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment) label = fromMaybe dLabel text in mkAnchor -< (href, label) formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree formatImage = proc (baseURI, Image src alt) -> let uri = case src of Left u -> u Right name -> mkObjectURI baseURI name href = uriToString id uri "" in ( eelem "img" += sattr "src" href += ( case alt of Just x -> sattr "alt" x Nothing -> none ) ) -<< () formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree formatExternalLink = proc (ExternalLink uri text) -> let href = uriToString id uri "" label = fromMaybe href text in mkAnchor -< (href, label) mkAnchor :: (ArrowXml a) => a (String, String) XmlTree mkAnchor = eelem "a" += attr "href" (arr fst >>> mkText) += (arr snd >>> mkText) attachXHtmlNS :: (ArrowXml a) => a XmlTree XmlTree attachXHtmlNS = processTopDown (changeQName attach `when` isElem) where attach :: QName -> QName attach qn = qn { namePrefix = "xhtml" , namespaceUri = "http://www.w3.org/1999/xhtml" }