X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FFormatter.hs;h=969c228a756ad93d269ff8d69d219466ece5bd99;hb=656fdb2772ab4de5cd083cbe9e7c1610cccef73b;hp=8d219d2a8e39b19b3a77893ce60ca99cb01db8a7;hpb=87e8b02490f9ca337c1a25de4454d4ad6d1492c6;p=Rakka.git

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 8d219d2..969c228 100644
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -18,8 +18,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)
+          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
@@ -28,15 +37,111 @@ formatBlock
     -> case block of
          Heading level text
              -> formatHeading -< (level, text)
+
+         HorizontalLine
+             -> eelem "hr" -< ()
+
+         list@(List _ _)
+             -> formatListElement -< (baseURI, list)
+
+         DefinitionList list
+             -> formatDefinitionList -< (baseURI, list)
+
+         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], [Element]) XmlTree
+      formatElem name
+          = proc (baseURI, attrs, contents)
+          -> ( eelem name
+               += ( arrL (fst . snd)
+                       >>>
+                       attrFromPair
+                  )
+               += ( (arr fst &&& arrL (snd . snd))
+                    >>>
+                    formatElement
+                  )
+             ) -< (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, BlockElement) XmlTree
+formatListElement 
+    = proc (baseURI, list)
+    -> let tag = case listType list of
+                   Bullet   -> "ul"
+                   Numbered -> "ol"
+       in
+         ( eelem tag
+           += ( (constA baseURI &&& constL (listItems list))
+                >>>
+                formatListItem
+              )
+         ) -<< ()
+      where
+        formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
+        formatListItem 
+            = proc (baseURI, item)
+            -> eelem "li"
+               += ( (arr fst &&& arrL snd)
+                    >>>
+                    formatElement
+                  ) -< (baseURI, item)
+
+
+formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
+formatDefinitionList 
+    = proc (baseURI, list)
+    -> ( eelem "dl"
+         += ( (arr fst &&& arrL snd)
+              >>>
+              formatDefinition
+            )
+       ) -< (baseURI, list)
+    where
+      formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
+      formatDefinition 
+          = proc (baseURI, def)
+          -> ( eelem "dt"
+               += ( (arr fst &&& arrL (defTerm . snd))
+                    >>>
+                    formatInline
+                  )
+               <+>
+               eelem "dd"
+               += ( (arr fst &&& arrL (defDesc . snd))
+                    >>>
+                    formatInline
+                  )
+             ) -< (baseURI, def)
+
+
+formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
+formatPreformatted
+    = eelem "pre"
+      += ( (arr fst &&& arrL snd)
+           >>>
+           formatInline
+         )
 
 
 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
@@ -55,23 +160,109 @@ formatInline
          Text text
              -> mkText -< text
 
+         Italic contents
+             -> formatElem "i" -< (baseURI, [], contents)
+
+         Bold contents
+             -> formatElem "b" -< (baseURI, [], contents)
+
+         link@(ObjectLink _ _)
+             -> formatObjectLink -< (baseURI, link)
+
          link@(PageLink _ _ _)
              -> formatPageLink -< (baseURI, link)
 
+         link@(ExternalLink _ _)
+             -> formatExternalLink -< link
+
+         LineBreak attrs
+             -> formatElem "br" -< (baseURI, attrs, [])
+
+         Span attrs contents
+             -> formatElem "span" -< (baseURI, attrs, contents)
+
+         img@(Image _ _)
+             -> formatImage -< (baseURI, img)
+
+         Anchor attrs contents
+             -> formatElem "a" -< (baseURI, attrs, contents)
+
+         Input attrs
+             -> formatElem "input" -< (baseURI, attrs, [])
+
+         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) -<< ()
+
+
+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 src alt)
+            -> let uri  = mkObjectURI baseURI src
+                   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)