X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FFormatter.hs;h=4a3531ce55a8035dfbad67dfd5f9eecc1a44c184;hb=396dbf64bef1796e9aaee706bc5ec4f1bcf06783;hp=1c3abe549d2a2445d22bd799fc15d1cf38c043a5;hpb=859d4378c2e2a1ccc8028821a37eeaa43aaa23fb;p=Rakka.git

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 1c3abe5..4a3531c 100644
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -4,12 +4,13 @@ module Rakka.Wiki.Formatter
     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
+import           Network.URI hiding (fragment)
 import           Rakka.Page
 import           Rakka.Wiki
 import           Text.XML.HXT.Arrow.XmlArrow
@@ -21,13 +22,13 @@ formatWikiBlocks
     = proc (baseURI, blocks)
     -> do block   <- arrL id     -< blocks
           tree    <- formatBlock -< (baseURI, block)
-          attachXHtmlNs -< tree
+          attachXHtmlNS -< tree
 
 
 formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
 formatElement 
-    = proc (baseURI, elem)
-    -> case elem of
+    = proc (baseURI, e)
+    -> case e of
          Block  b -> formatBlock  -< (baseURI, b)
          Inline i -> formatInline -< (baseURI, i)
 
@@ -59,6 +60,8 @@ formatBlock
 
          EmptyBlock
              -> none -< ()
+
+         _   -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block
     where
       formatElem :: (ArrowXml a, ArrowChoice a) =>
                     String
@@ -188,8 +191,13 @@ formatInline
          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
@@ -230,6 +238,7 @@ formatPageLink
                       (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
@@ -238,8 +247,10 @@ formatPageLink
 
 
 formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
-formatImage = proc (baseURI, Image name alt)
-            -> let uri  = mkObjectURI baseURI name
+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"
@@ -266,11 +277,11 @@ mkAnchor = eelem "a"
            += (arr snd >>> mkText)
 
 
-attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
-attachXHtmlNs = processBottomUp (changeQName attach')
+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"
-                   }
+      attach :: QName -> QName
+      attach qn = qn {
+                    namePrefix   = "xhtml"
+                  , namespaceUri = "http://www.w3.org/1999/xhtml"
+                  }