X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FFormatter.hs;h=5f7c7d8c10b952a1c7d7df404da7bc1667e2113c;hb=fcddebcc3cc02ae8d1904b9338334d538019e74a;hp=1054d174582a535acafb2a4a88c1d448f790ae30;hpb=8a7556db44cd91ac0bb52279472bcc2abaa3f18e;p=Rakka.git diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index 1054d17..5f7c7d8 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -1,70 +1,283 @@ module Rakka.Wiki.Formatter - ( formatWikiElements + ( formatWikiBlocks ) where import Control.Arrow +import Control.Arrow.ArrowIf import Control.Arrow.ArrowList -import Data.List +import Control.Arrow.ArrowTree +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 --- 複數の Inline を一つに纏める -packParagraph :: [WikiElement] -> [Either BlockElement [InlineElement]] -packParagraph elems = map pack grp - where - grp :: [[WikiElement]] - grp = groupBy criteria elems - - criteria :: WikiElement -> WikiElement -> Bool - criteria (Inline _) (Inline _) = True - criteria _ _ = False +formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree +formatWikiBlocks + = proc (baseURI, blocks) + -> do block <- arrL id -< blocks + tree <- formatBlock -< (baseURI, block) + attachXHtmlNS -< tree - pack :: [WikiElement] -> Either BlockElement [InlineElement] - pack (Block b : []) = Left b - pack xs = Right [ case x of - Inline i -> i | x <- xs ] - -formatWikiElements :: (ArrowXml a, ArrowChoice a) => a [WikiElement] XmlTree -formatWikiElements - = proc elems - -> do chunk <- arrL id -< packParagraph elems - case chunk of - Left x -> formatBlock -< x - Right xs -> formatParagraph -< xs +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 BlockElement XmlTree +formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree formatBlock - = proc b - -> do case b of - Header level text - -> formatHeader -< (level, text) - EmptyLine - -> none -< () + = 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) -formatHeader :: ArrowXml a => a (Int, String) XmlTree -formatHeader + 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) - -> selem ("h" ++ show level) [txt 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) -formatParagraph :: (ArrowXml a, ArrowChoice a) => a [InlineElement] XmlTree +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 - = proc xs - -> do elem <- arrL id -< xs - tree <- ( eelem "p" - += formatInline ) -< elem - returnA -< tree + = eelem "p" + += ( (arr fst &&& arrL snd) + >>> + formatInline + ) -formatInline :: (ArrowXml a, ArrowChoice a) => a InlineElement XmlTree +formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree formatInline - = proc i - -> do case i of - Text text - -> mkText -< text + = 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 = setNamePrefix' (newXName "xhtml") . + setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")