Implemented dummy trackback commands

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

diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs
index dd87751d29f53e65de60a06e1a404565941b846b..eb236ce1e54e57bab3d8c22cbd4e7433d193dc31 100644 (file)
--- a/Rakka/Wiki/Parser.hs
+++ b/Rakka/Wiki/Parser.hs
@@ -5,6 +5,7 @@ module Rakka.Wiki.Parser
     where
 
 import           Data.Maybe
+import           Network.URI
 import           Rakka.Wiki
 import           Text.ParserCombinators.Parsec
 
@@ -14,7 +15,7 @@ type CommandTypeOf = String -> Maybe CommandType
 
 wikiPage :: CommandTypeOf -> Parser WikiPage
 wikiPage cmdTypeOf
-    = do xs <- many $ try (blockElement cmdTypeOf)
+    = do xs <- many (blockElement cmdTypeOf)
          skipMany ( comment
                     <|>
                     (newline >> return ())
@@ -25,20 +26,19 @@ wikiPage cmdTypeOf
 
 blockElement :: CommandTypeOf -> Parser BlockElement
 blockElement cmdTypeOf
-    = skipMany ( comment
-                 <|>
-                 (newline >> return ())
-               )
-      >>
-      ( foldr (<|>) pzero [ heading
-                          , horizontalLine
-                          , listElement cmdTypeOf
-                          , definitionList cmdTypeOf
-                          , pdata
-                          , leadingSpaced cmdTypeOf
-                          , paragraph cmdTypeOf
-                          ]
-      )
+    = try $ do skipMany ( comment
+                          <|>
+                          (newline >> return ())
+                        )
+               foldr (<|>) pzero [ heading
+                                 , horizontalLine
+                                 , listElement cmdTypeOf
+                                 , definitionList cmdTypeOf
+                                 , pdata
+                                 , leadingSpaced cmdTypeOf
+                                 , paragraph cmdTypeOf
+                                 , blockCmd cmdTypeOf
+                                 ]
 
 
 heading :: Parser BlockElement
@@ -205,16 +205,15 @@ paragraph cmdTypeOf = paragraph' >>= return . Paragraph
                             <|>
                             try ( do newline
                                      ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
-                                     ((blockCommand              >> pzero) <|> return ())
                                      ys <- (paragraph' <|> return [])
                                      return (Text "\n" : ys)
-                                  -- \n があり、その次に \n、ブロックタ
-                                  -- グまたは blockSymbols があれば、
-                                  -- fail して 最初の newline を讀んだ
-                                  -- æ\89\80ã\81¾ã\81§å\8d·ã\81\8dæ\88»ã\81\99ã\80\82
+                                  -- \n があり、その次に \n または
+                                  -- blockSymbols があれば、fail して
+                                  -- 最初の newline を讀んだ所まで卷き
+                                  -- 戻す。
                                 )
                             <|>
-                            try paragraph'
+                            paragraph'
                             -- それ以外の場合は次の inlineElement から
                             -- を讀んで見る。但し一つも無くても良い。
                             <|>
@@ -222,6 +221,62 @@ paragraph cmdTypeOf = paragraph' >>= return . Paragraph
                       return (x:xs)
 
 
+blockCmd :: CommandTypeOf -> Parser BlockElement
+blockCmd cmdTypeOf
+    = (try $ do (tagName, tagAttrs) <- openTag
+                case cmdTypeOf tagName of
+                  Just BlockCommandType
+                      -> do xs <- contents
+                            closeTag tagName
+                            return $ BlockCmd $ BlockCommand {
+                                         bCmdName       = tagName
+                                       , bCmdAttributes = tagAttrs
+                                       , bCmdContents   = xs
+                                       }
+
+                  Just InlineCommandType
+                      -> pzero
+
+                  _   -> return $ undefinedCmdErr tagName
+      )
+      <|>
+      (try $ do (tagName, tagAttrs) <- emptyTag
+                case cmdTypeOf tagName of
+                  Just BlockCommandType
+                      -> return $ BlockCmd $ BlockCommand {
+                                         bCmdName       = tagName
+                                       , bCmdAttributes = tagAttrs
+                                       , bCmdContents   = []
+                                       }
+
+                  Just InlineCommandType
+                      -> pzero
+
+                  _   -> return $ undefinedCmdErr tagName
+      )
+      <?>
+      "block command"
+    where
+      contents :: Parser [BlockElement]
+      contents = do x  <- blockElement cmdTypeOf
+                    xs <- contents
+                    return (x:xs)
+                 <|>
+                 (newline >> contents)
+                 <|>
+                 (comment >> contents)
+                 <|>
+                 return []
+
+      undefinedCmdErr :: String -> BlockElement
+      undefinedCmdErr name
+          = Div [("class", "error")]
+            [ Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
+                               "Make sure you haven't mistyped.")
+                        ]
+            ]
+
+
 inlineElement :: CommandTypeOf -> Parser InlineElement
 inlineElement cmdTypeOf
     = try $ do skipMany comment
@@ -229,6 +284,7 @@ inlineElement cmdTypeOf
                                  , apostrophes cmdTypeOf
                                  , text
                                  , pageLink
+                                 , extLink
                                  , inlineCmd cmdTypeOf
                                  ]
 
@@ -307,6 +363,20 @@ pageLink = do try (string "[[")
            "page link"
 
 
+extLink :: Parser InlineElement
+extLink = do char '['
+             uriStr <- many1 (noneOf " \t]")
+             skipMany (oneOf " \t")
+             text <- option Nothing
+                     (many1 (noneOf "]") >>= return . Just)
+             
+             case parseURI uriStr of
+               Just uri -> char ']' >> return (ExternalLink uri text)
+               Nothing  -> pzero <?> "absolute URI"
+          <?>
+          "external link"
+
+
 inlineCmd :: CommandTypeOf -> Parser InlineElement
 inlineCmd cmdTypeOf
     = (try $ do (tagName, tagAttrs) <- openTag
@@ -317,7 +387,7 @@ inlineCmd cmdTypeOf
                             return $ InlineCmd $ InlineCommand {
                                          iCmdName       = tagName
                                        , iCmdAttributes = tagAttrs
-                                       , iCmdContents   =  xs
+                                       , iCmdContents   = xs
                                        }
                   _   -> pzero
       )
@@ -332,6 +402,8 @@ inlineCmd cmdTypeOf
                                        }
                   _   -> pzero
       )
+      <?>
+      "inline command"
     where
       contents :: Parser [InlineElement]
       contents = do x  <- inlineElement cmdTypeOf
@@ -408,7 +480,7 @@ comment = (try (string "<!--") >> skipTillEnd 1)
 
 
 blockSymbols :: [Char]
-blockSymbols = " =-*#;"
+blockSymbols = " =-*#;<"
 
 
 inlineSymbols :: [Char]