module Rakka.Wiki.Formatter
- ( formatWikiElements
+ ( formatWikiBlocks
)
where
import Control.Arrow
import Control.Arrow.ArrowList
+import Data.Char
import Data.List
+import Data.Maybe
+import Network.URI
+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)
+ returnA -< 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, elem)
+ -> case elem 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)
-formatHeader :: ArrowXml a => a (Int, String) XmlTree
-formatHeader
+ Div attrs contents
+ -> formatElem "div" -< (baseURI, attrs, contents)
+
+ EmptyBlock
+ -> none -< ()
+ 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 -< ()
+ 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
+ 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 = mkObjectURI baseURI src
+ 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)
projects / Rakka.git / blobdiff