Implemented block commands

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

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 13827690070fd7d2031b471f39fd315920026d51..8a9dc1778eb43ca248a8ba75b52b638f67b0bcaa 100644 (file)
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -1,5 +1,5 @@
 module Rakka.Wiki.Formatter
-    ( formatWikiElements
+    ( formatWikiBlocks
     )
     where
 
@@ -15,46 +15,121 @@ 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
-
-      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 ]
-                                                       
+formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
+formatWikiBlocks
+    = proc (baseURI, blocks)
+    -> do block <- arrL id -< blocks
+          formatBlock -< (baseURI, block)
 
-formatWikiElements :: (ArrowXml a, ArrowChoice a) => a (URI, [WikiElement]) XmlTree
-formatWikiElements
-    = proc (baseURI, elems)
-    -> do chunk <- arrL id -< packParagraph elems
-          case chunk of
-            Left  x  -> formatBlock     -< x
-            Right xs -> formatParagraph -< (baseURI, xs)
 
-
-formatBlock :: (ArrowXml a, ArrowChoice a) => a BlockElement XmlTree
+formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
 formatBlock 
-    = proc b
-    -> case b of
+    = proc (baseURI, block)
+    -> case block of
          Heading level text
              -> formatHeading -< (level, text)
-         EmptyLine
-             -> none -< ()
+
+         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
+             -> ( eelem "div"
+                  += ( arrL (fst . snd)
+                       >>>
+                       attrFromPair
+                     )
+                  += ( (arr fst &&& arrL (snd . snd))
+                       >>>
+                       formatBlock
+                     )
+                ) -< (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, 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    )
+
+
+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
@@ -73,9 +148,47 @@ formatInline
          Text text
              -> mkText -< text
 
+         Italic inlines
+             -> ( eelem "i"
+                  += ( (arr fst &&& arrL snd)
+                       >>>
+                       formatInline
+                     )
+                ) -< (baseURI, inlines)
+
+         Bold inlines
+             -> ( eelem "b"
+                  += ( (arr fst &&& arrL snd)
+                       >>>
+                       formatInline
+                     )
+                ) -< (baseURI, inlines)
+
          link@(PageLink _ _ _)
              -> formatPageLink -< (baseURI, link)
 
+         LineBreak attrs
+             -> ( eelem "br"
+                  += (arrL id >>> attrFromPair)
+                ) -< attrs
+
+         Span attrs contents
+             -> ( eelem "span"
+                  += ( 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) -<< ()
+
 
 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
 formatPageLink