From: pho <pho@cielonegro.org>
Date: Sat, 13 Oct 2007 02:33:19 +0000 (+0900)
Subject: The parser of frightening definition list has now been written!
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=commitdiff_plain;h=478a7dc233df921885184b06653735fdaf452305

The parser of frightening definition list has now been written!

darcs-hash:20071013023319-62b54-d63ad5fbd6333bd353562894614efdd78b58d781.gz
---

diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs
index 3b1802f..9f8bcdc 100644
--- a/Rakka/Wiki.hs
+++ b/Rakka/Wiki.hs
@@ -6,6 +6,8 @@ module Rakka.Wiki
     , ListElement(..)
     , ListType(..)
     , ListItem
+
+    , Definition(..)
     )
     where
 
@@ -22,6 +24,7 @@ data BlockElement
       }
     | HorizontalLine
     | List !ListElement
+    | DefinitionList ![Definition]
     | LeadingSpaced ![InlineElement]
     | Paragraph ![InlineElement]
     deriving (Eq, Show)
@@ -52,3 +55,11 @@ data ListType
 
 
 type ListItem = [Either ListElement InlineElement]
+
+
+data Definition
+    = Definition {
+        defTerm :: ![InlineElement]
+      , defDesc :: ![InlineElement]
+      }
+    deriving (Eq, Show)
\ No newline at end of file
diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 1246ab1..1792299 100644
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -35,6 +35,9 @@ formatBlock
          List list
              -> formatListElement -< (baseURI, list)
 
+         DefinitionList list
+             -> formatDefinitionList -< (baseURI, list)
+
          LeadingSpaced inlines
              -> formatLeadingSpaced -< (baseURI, inlines)
                 
@@ -79,6 +82,33 @@ formatListElement
                  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)
+
+
 formatLeadingSpaced :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
 formatLeadingSpaced 
     = eelem "pre"
diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs
index 83e3301..017df89 100644
--- a/Rakka/Wiki/Parser.hs
+++ b/Rakka/Wiki/Parser.hs
@@ -30,6 +30,8 @@ blockElement = skipMany ( comment
                  <|>
                  listElement
                  <|>
+                 definitionList
+                 <|>
                  leadingSpaced
                  <|>
                  paragraph
@@ -91,30 +93,55 @@ listElement = listElement' [] >>= return . List
                     )
                     <|>
                     return []
-{-
-      items stack = do nested <- listElement' stack
-                       rest   <- items stack
-                       return (Left nested : rest)
-                    <|>
-                    do xs   <- many1 inlineElement
-                       rest <- items stack
-                       return (Right xs : rest)
-                    <|>
-                    try ( newline
-                          >>
-                          string stack
-                          >>
-                          items stack
-                        )
-                    <|>
-                    return []
--}
 
       toType :: Char -> ListType
       toType '*' = Bullet
       toType '#' = Numbered
 
 
+definitionList :: Parser BlockElement
+definitionList = many1 definition >>= return . DefinitionList
+    where
+      definition :: Parser Definition
+      definition = do char ';'
+                      ws
+                      tHead <- inlineElement
+                      tRest <- term
+                      d     <- description
+                      return (Definition (tHead:tRest) d)
+                   <?>
+                   "definition list"
+
+      term :: Parser [InlineElement]
+      term = (char ':' >> ws >> return [])
+             <|>
+             (newline >> char ':' >> ws >> return [])
+             <|>
+             do x  <- inlineElement
+                xs <- term
+                return (x:xs)
+             <?>
+             "term to be defined"
+
+      description :: Parser [InlineElement]
+      description = do x  <- inlineElement
+                       xs <- description
+                       return (x:xs)
+                    <|>
+                    try ( do newline
+                             char ':'
+                             ws
+                             xs <- description
+                             return (Text "\n" : xs)
+                        )
+                    <|>
+                    (newline >> return [])
+                    <|>
+                    (eof >> return [])
+                    <?>
+                    "description of term"
+
+
 leadingSpaced :: Parser BlockElement
 leadingSpaced = char ' ' >> leadingSpaced' >>= return . LeadingSpaced
     where
@@ -180,7 +207,18 @@ inlineElement = skipMany comment
 
 
 text :: Parser InlineElement
-text = many1 (noneOf ('\n':inlineSymbols)) >>= return . Text
+text = ( char ':'
+         >>
+         many (noneOf ('\n':':':inlineSymbols))
+         >>=
+         return . Text . (':' :)
+         -- 定義リストとの關係上、コロンは先頭にしか存在できない。
+       )
+       <|>
+       ( many1 (noneOf ('\n':':':inlineSymbols))
+         >>=
+         return . Text
+       )
 
 
 pageLink :: Parser InlineElement
@@ -219,7 +257,7 @@ comment = (try (string "<!--") >> skipTillEnd 1)
 
 
 blockSymbols :: [Char]
-blockSymbols = " =-*#"
+blockSymbols = " =-*#;"
 
 
 inlineSymbols :: [Char]
diff --git a/defaultPages/MainPage b/defaultPages/MainPage
index 471246b..5ae8b00 100644
--- a/defaultPages/MainPage
+++ b/defaultPages/MainPage
@@ -33,6 +33,8 @@ Another paragraph...
 * bar
 ** baz
 
+aaaaa
+
 # foo
 ## bar
 ### baz
@@ -42,14 +44,20 @@ Another paragraph...
 *#* baz
 *# bar
 
+== Definition ==
+; AAA : aaaaaaaaaaaaaaaaa
+; BBBBBBBBB
+: bbb
+: ccccccccccc
+
 == Link ==
-[[Page]]
-[[page]]
-[[space in a page name]]
-[[Page|Link to "Page"]]
-[[Page#Heading]]
-[[#Heading]]
-[[Page#Heading|Link to "Page#Heading"]]
-[[#example]]
+* [[Page]]
+* [[page]]
+* [[space in a page name]]
+* [[Page|Link to "Page"]]
+* [[Page#Heading]]
+* [[#Heading]]
+* [[Page#Heading|Link to "Page#Heading"]]
+* [[#example]]
 </textData>
 </page>
diff --git a/defaultPages/StyleSheet/Default b/defaultPages/StyleSheet/Default
index e618b98..bde37fb 100644
--- a/defaultPages/StyleSheet/Default
+++ b/defaultPages/StyleSheet/Default
@@ -78,6 +78,20 @@
     margin-left: 20px;
 }
 
+.body dl {
+    margin: 1em 2em;
+}
+.body dt {
+    font-weight: bold;
+}
+.body dd {
+    margin-left: 3em;
+    margin-top: 0.1em;
+}
+.body dd + dt {
+    margin-top: 0.9em;
+}
+
 .side-bar .content {
     padding: 20px;
 }
diff --git a/test/WikiParserTest.hs b/test/WikiParserTest.hs
index 7e18741..5434015 100644
--- a/test/WikiParserTest.hs
+++ b/test/WikiParserTest.hs
@@ -215,4 +215,28 @@ testData = [ (parseWiki ""
               (Right [ List (ListElement Bullet   [ [Right (Text "a")] ])
                      , List (ListElement Numbered [ [Right (Text "b")] ])
                      ]))
+
+           , (parseWiki "foo:bar"
+              ~?=
+              (Right [ Paragraph [ Text "foo"
+                                 , Text ":bar"
+                                 ]
+                     ]))
+
+           , (parseWiki "; foo: bar"
+              ~?=
+              (Right [ DefinitionList [Definition [Text "foo"] [Text "bar"]] ]))
+
+           , (parseWiki "; foo: bar\n"
+              ~?=
+              (Right [ DefinitionList [Definition [Text "foo"] [Text "bar"]] ]))
+
+           , (parseWiki "; foo\n: bar\n; bar\n: baz\n: baz"
+              ~?=
+              (Right [ DefinitionList [ Definition [Text "foo"] [ Text "bar" ]
+                                      , Definition [Text "bar"] [ Text "baz"
+                                                                , Text "\n"
+                                                                , Text "baz" ]
+                                      ]
+                     ]))
            ]