implemented listing

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

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 1054d174582a535acafb2a4a88c1d448f790ae30..1246ab1e61b16dc42b368e5f419aa85af70c2da3 100644 (file)
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -1,70 +1,126 @@
 module Rakka.Wiki.Formatter
-    ( formatWikiElements
+    ( formatWikiBlocks
     )
     where
 
 import           Control.Arrow
 import           Control.Arrow.ArrowList
+import           Data.Char
 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
 
 
--- 複數の Inline を一つに纏める
-packParagraph :: [WikiElement] -> [Either BlockElement [InlineElement]]
-packParagraph elems = map pack grp
-    where
-      grp :: [[WikiElement]]
-      grp = groupBy criteria elems
+formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
+formatWikiBlocks
+    = proc (baseURI, blocks)
+    -> do block <- arrL id -< blocks
+          formatBlock -< (baseURI, block)
 
-      criteria :: WikiElement -> WikiElement -> Bool
-      criteria (Inline _) (Inline _) = True
-      criteria _ _                   = False
 
-      pack :: [WikiElement] -> Either BlockElement [InlineElement]
-      pack (Block b : []) = Left b
-      pack xs             = Right [ case x of
-                                      Inline i -> i | x <- xs ]
-                                                       
+formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
+formatBlock 
+    = proc (baseURI, block)
+    -> case block of
+         Heading level text
+             -> formatHeading -< (level, text)
 
-formatWikiElements :: (ArrowXml a, ArrowChoice a) => a [WikiElement] XmlTree
-formatWikiElements
-    = proc elems
-    -> do chunk <- arrL id -< packParagraph elems
-          case chunk of
-            Left  x  -> formatBlock     -< x
-            Right xs -> formatParagraph -< xs
+         HorizontalLine
+             -> eelem "hr" -< ()
 
+         List list
+             -> formatListElement -< (baseURI, list)
 
-formatBlock :: (ArrowXml a, ArrowChoice a) => a BlockElement XmlTree
-formatBlock 
-    = proc b
-    -> do case b of
-            Header level text
-                -> formatHeader -< (level, text)
-            EmptyLine
-                -> none -< ()
+         LeadingSpaced inlines
+             -> formatLeadingSpaced -< (baseURI, inlines)
+                
+         Paragraph inlines
+             -> formatParagraph -< (baseURI, inlines)
 
 
-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
+formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) 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)
+                    >>>
+                    formatListItem'
+                  ) -< (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    )
+
+
+formatLeadingSpaced :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
+formatLeadingSpaced 
+    = eelem "pre"
+      += ( (arr fst &&& arrL snd)
+           >>>
+           formatInline
+         )
+
+
+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 (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)
+           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)