The parser of frightening definition list has now been written!

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

diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs
index 0125419c45d6d3fda915dfb8785462ec3572b00e..017df8952fb09bfce930ca4c2ecd950f50ed8b3d 100644 (file)
--- a/Rakka/Wiki/Parser.hs
+++ b/Rakka/Wiki/Parser.hs
@@ -3,6 +3,7 @@ module Rakka.Wiki.Parser
     )
     where
 
+import           Data.Maybe
 import           Rakka.Wiki
 import           Text.ParserCombinators.Parsec
 
@@ -24,6 +25,14 @@ blockElement = skipMany ( comment
                         )
                >>
                ( heading
+                 <|>
+                 horizontalLine
+                 <|>
+                 listElement
+                 <|>
+                 definitionList
+                 <|>
+                 leadingSpaced
                  <|>
                  paragraph
                )
@@ -49,6 +58,114 @@ heading = foldr (<|>) pzero (map heading' [1..5])
                       return (Heading n (x:xs))
 
 
+horizontalLine :: Parser BlockElement
+horizontalLine = try $ do count 4 (char '-')
+                          many (char '-')
+                          ws
+                          eol
+                          return HorizontalLine
+
+
+listElement :: Parser BlockElement
+listElement = listElement' [] >>= return . List
+    where
+      listElement' :: [Char] -> Parser ListElement
+      listElement' stack
+          = try $ do t  <- oneOf "*#"
+                     ws
+                     xs <- items (stack ++ [t])
+                     return (ListElement (toType t) xs)
+
+      -- ListItem の終了條件は、
+      items :: [Char] -> Parser [ListItem]
+      items stack = do xs     <- many1 inlineElement
+                       nested <- option Nothing
+                                 $ try $ do newline
+                                            string stack
+                                            listElement' stack >>= return . Just
+                       rest <- items stack
+                       return $ (map Right xs ++ map Left (catMaybes [nested])) : rest
+                    <|>
+                    (try $ do newline
+                              string stack
+                              ws
+                              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
+      leadingSpaced' :: Parser [InlineElement]
+      leadingSpaced' = do x  <- inlineElement
+                          xs <- leadingSpaced'
+                          return (x:xs)
+                       <|>
+                       try ( newline
+                             >>
+                             char ' '
+                             >>
+                             leadingSpaced'
+                             >>=
+                             return . (Text "\n" :)
+                           )
+                       <|>
+                       return []
+
+
+blockTag :: Parser BlockElement
+blockTag = pzero -- not implemented
+
+
 paragraph :: Parser BlockElement
 paragraph = paragraph' >>= return . Paragraph
     where
@@ -63,12 +180,13 @@ paragraph = paragraph' >>= return . Paragraph
                             <|>
                             try ( do newline
                                      ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
+                                     ((blockTag                  >> pzero) <|> return ())
                                      ys <- (paragraph' <|> return [])
                                      return (Text "\n" : ys)
-                                  -- \n があり、その次に \n または
-                                  -- blockSymbols があれば、fail して
-                                  -- 最初の newline を讀んだ所まで卷き
-                                  -- 戻す。
+                                  -- \n があり、その次に \n、ブロックタ
+                                  -- グまたは blockSymbols があれば、
+                                  -- fail して 最初の newline を讀んだ
+                                  -- æ\89\80ã\81¾ã\81§å\8d·ã\81\8dæ\88»ã\81\99ã\80\82
                                 )
                             <|>
                             try paragraph'
@@ -89,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
@@ -128,7 +257,7 @@ comment = (try (string "<!--") >> skipTillEnd 1)
 
 
 blockSymbols :: [Char]
-blockSymbols = "="
+blockSymbols = " =-*#;"
 
 
 inlineSymbols :: [Char]