Record before chucking Data.Generics. It's way too slow.

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

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index cc51feff644c86a6f3d714adb1bdb27955b098e7..4b483db37dba260310b2263ea644db9085684b3c 100644 (file)
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -5,7 +5,6 @@ module Rakka.Wiki.Formatter
 
 import           Control.Arrow
 import           Control.Arrow.ArrowList
-import           Control.Arrow.ArrowTree
 import           Data.Char
 import           Data.List
 import           Data.Maybe
@@ -21,7 +20,15 @@ formatWikiBlocks
     = proc (baseURI, blocks)
     -> do block   <- arrL id     -< blocks
           tree    <- formatBlock -< (baseURI, block)
-          attachXHtmlNs -< tree
+          returnA -< 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
@@ -34,7 +41,7 @@ formatBlock
          HorizontalLine
              -> eelem "hr" -< ()
 
-         List list
+         list@(List _ _)
              -> formatListElement -< (baseURI, list)
 
          DefinitionList list
@@ -54,7 +61,7 @@ formatBlock
     where
       formatElem :: (ArrowXml a, ArrowChoice a) =>
                     String
-                 -> a (URI, [Attribute], [BlockElement]) XmlTree
+                 -> a (URI, [Attribute], [Element]) XmlTree
       formatElem name
           = proc (baseURI, attrs, contents)
           -> ( eelem name
@@ -64,7 +71,7 @@ formatBlock
                   )
                += ( (arr fst &&& arrL (snd . snd))
                     >>>
-                    formatBlock
+                    formatElement
                   )
              ) -< (baseURI, (attrs, contents))
 
@@ -77,7 +84,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
@@ -97,16 +104,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 
@@ -187,6 +187,9 @@ formatInline
          Anchor attrs contents
              -> formatElem "a" -< (baseURI, attrs, contents)
 
+         Input attrs
+             -> formatElem "input" -< (baseURI, attrs, [])
+
          EmptyInline
              -> none -< ()
     where
@@ -228,7 +231,7 @@ formatPageLink
     -> let uri    = case (page, fragment) of
                       (Just  x, Just  y) -> mkPageFragmentURI baseURI x y
                       (Just  x, Nothing) -> mkPageURI baseURI x
-                      (Nothing, Just  y) -> nullURI { uriFragment = ('#':y) }
+                      (Nothing, Just  y) -> mkFragmentURI y
            href   = uriToString id uri ""
            dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
            label  = fromMaybe dLabel text
@@ -237,8 +240,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  uri  -> uri
+                            Right name -> mkObjectURI baseURI name
                    href = uriToString id uri ""
                in
                  ( eelem "img"
@@ -263,13 +268,3 @@ 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 = processBottomUp (changeQName attach')
-    where
-      attach' :: QName -> QName
-      attach' qn = qn {
-                     namePrefix   = "xhtml"
-                   , namespaceUri = "http://www.w3.org/1999/xhtml"
-                   }