wrote more...

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

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 1054d174582a535acafb2a4a88c1d448f790ae30..f5239381f1d718b38cc2c146ac226836ac4345c9 100644 (file)
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -6,6 +6,9 @@ module Rakka.Wiki.Formatter
 import           Control.Arrow
 import           Control.Arrow.ArrowList
 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
@@ -28,43 +31,63 @@ packParagraph elems = map pack grp
                                       Inline i -> i | x <- xs ]
                                                        
 
-formatWikiElements :: (ArrowXml a, ArrowChoice a) => a [WikiElement] XmlTree
+formatWikiElements :: (ArrowXml a, ArrowChoice a) => a (URI, [WikiElement]) XmlTree
 formatWikiElements
-    = proc elems
+    = proc (baseURI, elems)
     -> do chunk <- arrL id -< packParagraph elems
           case chunk of
             Left  x  -> formatBlock     -< x
-            Right xs -> formatParagraph -< xs
+            Right xs -> formatParagraph -< (baseURI, xs)
 
 
 formatBlock :: (ArrowXml a, ArrowChoice a) => a BlockElement XmlTree
 formatBlock 
     = proc b
-    -> do case b of
-            Header level text
-                -> formatHeader -< (level, text)
-            EmptyLine
-                -> none -< ()
+    -> case b of
+         Heading level text
+             -> formatHeading -< (level, text)
+         EmptyLine
+             -> none -< ()
 
 
-formatHeader :: ArrowXml a => a (Int, String) XmlTree
-formatHeader 
+formatHeading :: ArrowXml a => a (Int, String) XmlTree
+formatHeading 
     = proc (level, text)
     -> selem ("h" ++ show level) [txt text] -<< ()
 
 
-formatParagraph :: (ArrowXml a, ArrowChoice a) => a [InlineElement] XmlTree
+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
+
+         link@(PageLink _ _ _)
+             -> formatPageLink -< (baseURI, link)
+
+
+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) -> nullURI { uriFragment = ('#':y) }
+           href   = uriToString id uri ""
+           dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
+           label  = fromMaybe dLabel text
+       in
+         ( eelem "a"
+           += attr "href" (arr fst >>> mkText)
+           += (arr snd >>> mkText)
+         ) -< (href, label)