X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FFormatter.hs;h=1c3abe549d2a2445d22bd799fc15d1cf38c043a5;hb=859d4378c2e2a1ccc8028821a37eeaa43aaa23fb;hp=8a9dc1778eb43ca248a8ba75b52b638f67b0bcaa;hpb=f832f12703d807f5fc3350dc71d8624ffc5b97a5;p=Rakka.git

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 8a9dc17..1c3abe5 100644
--- 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,17 @@ 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
+
+
+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 (URI, BlockElement) XmlTree
@@ -32,7 +42,7 @@ formatBlock
          HorizontalLine
              -> eelem "hr" -< ()
 
-         List list
+         list@(List _ _)
              -> formatListElement -< (baseURI, list)
 
          DefinitionList list
@@ -45,16 +55,26 @@ formatBlock
              -> formatParagraph -< (baseURI, inlines)
 
          Div attrs contents
-             -> ( eelem "div"
-                  += ( arrL (fst . snd)
+             -> 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))
-                       >>>
-                       formatBlock
-                     )
-                ) -< (baseURI, (attrs, contents))
+                  )
+               += ( (arr fst &&& arrL (snd . snd))
+                    >>>
+                    formatElement
+                  )
+             ) -< (baseURI, (attrs, contents))
 
 
 formatHeading :: ArrowXml a => a (Int, String) XmlTree
@@ -65,7 +85,7 @@ formatHeading
        [ txt text        ] -<< ()
 
 
-formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
+formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
 formatListElement 
     = proc (baseURI, list)
     -> let tag = case listType list of
@@ -85,16 +105,9 @@ formatListElement
             -> eelem "li"
                += ( (arr fst &&& arrL snd)
                     >>>
-                    formatListItem'
+                    formatElement
                   ) -< (baseURI, item)
 
-        formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree
-        formatListItem' 
-            = proc (baseURI, x)
-            -> case x of
-                 Left  nestedList -> formatListElement -< (baseURI, nestedList)
-                 Right inline     -> formatInline      -< (baseURI, inline    )
-
 
 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
 formatDefinitionList 
@@ -148,41 +161,51 @@ formatInline
          Text text
              -> mkText -< text
 
-         Italic inlines
-             -> ( eelem "i"
-                  += ( (arr fst &&& arrL snd)
-                       >>>
-                       formatInline
-                     )
-                ) -< (baseURI, inlines)
+         Italic contents
+             -> formatElem "i" -< (baseURI, [], contents)
 
-         Bold inlines
-             -> ( eelem "b"
-                  += ( (arr fst &&& arrL snd)
-                       >>>
-                       formatInline
-                     )
-                ) -< (baseURI, inlines)
+         Bold contents
+             -> formatElem "b" -< (baseURI, [], contents)
+
+         link@(ObjectLink _ _)
+             -> formatObjectLink -< (baseURI, link)
 
          link@(PageLink _ _ _)
              -> formatPageLink -< (baseURI, link)
 
+         link@(ExternalLink _ _)
+             -> formatExternalLink -< link
+
          LineBreak attrs
-             -> ( eelem "br"
-                  += (arrL id >>> attrFromPair)
-                ) -< attrs
+             -> formatElem "br" -< (baseURI, attrs, [])
 
          Span attrs contents
-             -> ( eelem "span"
-                  += ( arrL (fst . snd)
+             -> formatElem "span" -< (baseURI, attrs, contents)
+
+         img@(Image _ _)
+             -> formatImage -< (baseURI, img)
+
+         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))
+                  )
+               += ( (arr fst &&& arrL (snd . snd))
+                    >>>
+                    formatInline
+                  )
+             ) -< (baseURI, (attrs, contents))
 
 
 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
@@ -190,19 +213,64 @@ 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 (fix x) y
-                      (Just  x, Nothing) -> mkPageURI baseURI (fix x)
-                      (Nothing, Just  y) -> nullURI { uriFragment = ('#':y) }
-           fix    = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
+                      (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
-         ( eelem "a"
+         mkAnchor -< (href, label)
+
+
+formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
+formatImage = proc (baseURI, Image name alt)
+            -> let uri  = 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)
-         ) -< (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"
+                   }