Implemented the outline command

[Rakka.git] / Rakka / Wiki / Formatter.hs

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 1792299d3c0a09a990ea817fee7078d7aabcdce1..b81c510594f75253678f9dfc7995899e627615c5 100644 (file)
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -5,6 +5,7 @@ module Rakka.Wiki.Formatter
 
 import           Control.Arrow
 import           Control.Arrow.ArrowList
+import           Control.Arrow.ArrowTree
 import           Data.Char
 import           Data.List
 import           Data.Maybe
@@ -18,8 +19,9 @@ import           Text.XML.HXT.DOM.TypeDefs
 formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
 formatWikiBlocks
     = proc (baseURI, blocks)
-    -> do block <- arrL id -< blocks
-          formatBlock -< (baseURI, block)
+    -> do block   <- arrL id     -< blocks
+          tree    <- formatBlock -< (baseURI, block)
+          attachXHtmlNs -< tree
 
 
 formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
@@ -38,17 +40,41 @@ formatBlock
          DefinitionList list
              -> formatDefinitionList -< (baseURI, list)
 
-         LeadingSpaced inlines
-             -> formatLeadingSpaced -< (baseURI, inlines)
+         Preformatted inlines
+             -> formatPreformatted -< (baseURI, inlines)
                 
          Paragraph inlines
              -> formatParagraph -< (baseURI, inlines)
 
+         Div attrs contents
+             -> formatElem "div" -< (baseURI, attrs, contents)
+
+         EmptyBlock
+             -> none -< ()
+    where
+      formatElem :: (ArrowXml a, ArrowChoice a) =>
+                    String
+                 -> a (URI, [Attribute], [BlockElement]) XmlTree
+      formatElem name
+          = proc (baseURI, attrs, contents)
+          -> ( eelem name
+               += ( arrL (fst . snd)
+                       >>>
+                       attrFromPair
+                  )
+               += ( (arr fst &&& arrL (snd . snd))
+                    >>>
+                    formatBlock
+                  )
+             ) -< (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, ListElement) XmlTree
@@ -109,8 +135,8 @@ formatDefinitionList
              ) -< (baseURI, def)
 
 
-formatLeadingSpaced :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
-formatLeadingSpaced 
+formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
+formatPreformatted
     = eelem "pre"
       += ( (arr fst &&& arrL snd)
            >>>
@@ -134,9 +160,54 @@ formatInline
          Text text
              -> mkText -< text
 
+         Italic contents
+             -> formatElem "i" -< (baseURI, [], contents)
+
+         Bold contents
+             -> formatElem "b" -< (baseURI, [], contents)
+
          link@(PageLink _ _ _)
              -> formatPageLink -< (baseURI, link)
 
+         link@(ExternalLink _ _)
+             -> formatExternalLink -< link
+
+         LineBreak attrs
+             -> formatElem "br" -< (baseURI, attrs, [])
+
+         Span attrs contents
+             -> formatElem "span" -< (baseURI, attrs, contents)
+
+         Image attrs
+             -> formatElem "img" -< (baseURI, attrs, [])
+
+         Anchor attrs contents
+             -> formatElem "a" -< (baseURI, attrs, contents)
+
+         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) -<< ()
+
 
 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
 formatPageLink 
@@ -154,3 +225,25 @@ formatPageLink
            += attr "href" (arr fst >>> mkText)
            += (arr snd >>> mkText)
          ) -< (href, label)
+
+
+formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
+formatExternalLink 
+    = proc (ExternalLink uri text)
+    -> let href  = uriToString id uri ""
+           label = fromMaybe href text
+       in
+         ( eelem "a"
+           += attr "href" (arr fst >>> mkText)
+           += (arr snd >>> mkText)
+         ) -< (href, label)
+
+
+attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
+attachXHtmlNs = processBottomUp (changeQName attach')
+    where
+      attach' :: QName -> QName
+      attach' qn = qn {
+                     namePrefix   = "xhtml"
+                   , namespaceUri = "http://www.w3.org/1999/xhtml"
+                   }