X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FParser.hs;h=33b68bd0ef0112df1b23f0ea7463a9e76e980f27;hb=43113f26d3e61c96d896724c5509abe67b6a99e7;hp=017df8952fb09bfce930ca4c2ecd950f50ed8b3d;hpb=478a7dc233df921885184b06653735fdaf452305;p=Rakka.git

diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs
index 017df89..33b68bd 100644
--- a/Rakka/Wiki/Parser.hs
+++ b/Rakka/Wiki/Parser.hs
@@ -1,41 +1,44 @@
 module Rakka.Wiki.Parser
-    ( wikiPage
+    ( CommandTypeOf
+    , wikiPage
     )
     where
 
 import           Data.Maybe
+import           Network.URI hiding (fragment)
 import           Rakka.Wiki
-import           Text.ParserCombinators.Parsec
+import           Text.ParserCombinators.Parsec hiding (label)
 
 
-wikiPage :: Parser WikiPage
-wikiPage = do xs <- many (try blockElement)
-              skipMany ( comment
-                         <|>
-                         (newline >> return ())
-                       )
-              eof
-              return xs
+type CommandTypeOf = String -> Maybe CommandType
 
 
-blockElement :: Parser BlockElement
-blockElement = skipMany ( comment
+wikiPage :: CommandTypeOf -> Parser WikiPage
+wikiPage cmdTypeOf
+    = do xs <- many (blockElement cmdTypeOf)
+         skipMany ( comment
+                    <|>
+                    (newline >> return ())
+                  )
+         eof
+         return xs
+
+
+blockElement :: CommandTypeOf -> Parser BlockElement
+blockElement cmdTypeOf
+    = try $ do skipMany ( comment
                           <|>
                           (newline >> return ())
                         )
-               >>
-               ( heading
-                 <|>
-                 horizontalLine
-                 <|>
-                 listElement
-                 <|>
-                 definitionList
-                 <|>
-                 leadingSpaced
-                 <|>
-                 paragraph
-               )
+               foldr (<|>) pzero [ heading
+                                 , horizontalLine
+                                 , listElement cmdTypeOf
+                                 , definitionList cmdTypeOf
+                                 , verbatim
+                                 , leadingSpaced cmdTypeOf
+                                 , paragraph cmdTypeOf
+                                 , blockCmd cmdTypeOf
+                                 ]
 
 
 heading :: Parser BlockElement
@@ -50,7 +53,7 @@ heading = foldr (<|>) pzero (map heading' [1..5])
                       x  <- notFollowedBy (char '=') >> anyChar
                       xs <- manyTill anyChar (try $ ws >> ( count n (char '=')
                                                             <?>
-                                                            ("trailing " ++ take n (repeat '='))
+                                                            ("trailing " ++ replicate n '=')
                                                           )
                                              )
                       ws
@@ -59,34 +62,38 @@ heading = foldr (<|>) pzero (map heading' [1..5])
 
 
 horizontalLine :: Parser BlockElement
-horizontalLine = try $ do count 4 (char '-')
+horizontalLine = try ( do count 4 (char '-')
                           many (char '-')
                           ws
                           eol
                           return HorizontalLine
+                     )
+                 <?>
+                 "horizontal line"
 
 
-listElement :: Parser BlockElement
-listElement = listElement' [] >>= return . List
+listElement :: CommandTypeOf -> Parser BlockElement
+listElement cmdTypeOf = listElement' []
     where
-      listElement' :: [Char] -> Parser ListElement
+      listElement' :: [Char] -> Parser BlockElement
       listElement' stack
-          = try $ do t  <- oneOf "*#"
-                     ws
-                     xs <- items (stack ++ [t])
-                     return (ListElement (toType t) xs)
+          = do t  <- oneOf "*#"
+               ws
+               xs <- items (stack ++ [t])
+               return (List (toType t) xs)
 
-      -- ListItem の終了條件は、
       items :: [Char] -> Parser [ListItem]
-      items stack = do xs     <- many1 inlineElement
+      items stack = do xs     <- many1 $ inlineElement cmdTypeOf
                        nested <- option Nothing
-                                 $ try $ do newline
+                                 $ try $ do skipMany comment
+                                            newline
                                             string stack
-                                            listElement' stack >>= return . Just
+                                            liftM Just (listElement' stack)
                        rest <- items stack
-                       return $ (map Right xs ++ map Left (catMaybes [nested])) : rest
+                       return $ (map Inline xs ++ map Block (catMaybes [nested])) : rest
                     <|>
-                    (try $ do newline
+                    (try $ do skipMany comment
+                              newline
                               string stack
                               ws
                               items stack
@@ -97,15 +104,16 @@ listElement = listElement' [] >>= return . List
       toType :: Char -> ListType
       toType '*' = Bullet
       toType '#' = Numbered
+      toType _   = undefined
 
 
-definitionList :: Parser BlockElement
-definitionList = many1 definition >>= return . DefinitionList
+definitionList :: CommandTypeOf -> Parser BlockElement
+definitionList cmdTypeOf = liftM DefinitionList (many1 definition)
     where
       definition :: Parser Definition
       definition = do char ';'
                       ws
-                      tHead <- inlineElement
+                      tHead <- inlineElement cmdTypeOf
                       tRest <- term
                       d     <- description
                       return (Definition (tHead:tRest) d)
@@ -117,14 +125,14 @@ definitionList = many1 definition >>= return . DefinitionList
              <|>
              (newline >> char ':' >> ws >> return [])
              <|>
-             do x  <- inlineElement
+             do x  <- inlineElement cmdTypeOf
                 xs <- term
                 return (x:xs)
              <?>
              "term to be defined"
 
       description :: Parser [InlineElement]
-      description = do x  <- inlineElement
+      description = do x  <- inlineElement cmdTypeOf
                        xs <- description
                        return (x:xs)
                     <|>
@@ -142,35 +150,47 @@ definitionList = many1 definition >>= return . DefinitionList
                     "description of term"
 
 
-leadingSpaced :: Parser BlockElement
-leadingSpaced = char ' ' >> leadingSpaced' >>= return . LeadingSpaced
+verbatim :: Parser BlockElement
+verbatim = do try (string "<!verbatim[")
+              many (oneOf " \t\n")
+              x <- verbatim'
+              return (Preformatted [Text x])
+    where
+      verbatim' :: Parser String
+      verbatim' = do try (many (oneOf " \t\n") >> string "]>")
+                     return []
+                  <|>
+                  do x  <- anyChar
+                     xs <- verbatim'
+                     return (x:xs)
+
+
+leadingSpaced :: CommandTypeOf -> Parser BlockElement
+leadingSpaced cmdTypeOf = liftM Preformatted (char ' ' >> leadingSpaced')
+                          <?>
+                          "leading space"
     where
       leadingSpaced' :: Parser [InlineElement]
-      leadingSpaced' = do x  <- inlineElement
+      leadingSpaced' = do x  <- inlineElement cmdTypeOf
                           xs <- leadingSpaced'
                           return (x:xs)
                        <|>
-                       try ( newline
-                             >>
-                             char ' '
-                             >>
-                             leadingSpaced'
-                             >>=
-                             return . (Text "\n" :)
+                       try ( liftM (Text "\n" :) ( newline
+                                                   >>
+                                                   char ' '
+                                                   >>
+                                                   leadingSpaced'
+                                                 )
                            )
                        <|>
                        return []
 
 
-blockTag :: Parser BlockElement
-blockTag = pzero -- not implemented
-
-
-paragraph :: Parser BlockElement
-paragraph = paragraph' >>= return . Paragraph
+paragraph :: CommandTypeOf -> Parser BlockElement
+paragraph cmdTypeOf = liftM Paragraph paragraph'
     where
       paragraph' :: Parser [InlineElement]
-      paragraph' = do x  <- inlineElement
+      paragraph' = do x  <- inlineElement cmdTypeOf
                       xs <- try ( do newline
                                      eof
                                      return []
@@ -180,16 +200,15 @@ 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 を讀んだ所まで卷き
+                                  -- 戻す。
                                 )
                             <|>
-                            try paragraph'
+                            paragraph'
                             -- それ以外の場合は次の inlineElement から
                             -- を讀んで見る。但し一つも無くても良い。
                             <|>
@@ -197,71 +216,276 @@ paragraph = paragraph' >>= return . Paragraph
                       return (x:xs)
 
 
-inlineElement :: Parser InlineElement
-inlineElement = skipMany comment
-                >>
-                ( try text
-                  <|>
-                  try pageLink
-                )
+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")]
+            [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
+                                      "Make sure you haven't mistyped.")
+                               ])
+            ]
+
+
+inlineElement :: CommandTypeOf -> Parser InlineElement
+inlineElement cmdTypeOf
+    = try $ do skipMany comment
+               foldr (<|>) pzero [ nowiki
+                                 , apostrophes cmdTypeOf
+                                 , text
+                                 , objLink
+                                 , pageLink
+                                 , extLink
+                                 , inlineCmd cmdTypeOf
+                                 ]
+
+
+nowiki :: Parser InlineElement
+nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
+    where
+      nowiki' :: Parser String
+      nowiki' = do try (string "]>")
+                   return []
+                <|>
+                do x  <- anyChar
+                   xs <- nowiki'
+                   return (x:xs)
 
 
 text :: Parser InlineElement
-text = ( char ':'
-         >>
-         many (noneOf ('\n':':':inlineSymbols))
-         >>=
-         return . Text . (':' :)
-         -- 定義リストとの關係上、コロンは先頭にしか存在できない。
-       )
+text = liftM (Text . (':' :)) ( char ':'
+                                >>
+                                many (noneOf ('\n':inlineSymbols))
+                              )
+       -- 定義リストとの關係上、コロンは先頭にしか來られない。
        <|>
-       ( many1 (noneOf ('\n':':':inlineSymbols))
-         >>=
-         return . Text
-       )
+       liftM Text (many1 (noneOf ('\n':inlineSymbols)))
+       <?>
+       "text"
+
+
+apostrophes :: CommandTypeOf -> Parser InlineElement
+apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
+    where
+      apos1 = apos 1 >> return (Text "'")
+
+      apos2 = do apos 2
+                 xs <- many1 $ inlineElement cmdTypeOf
+                 apos 2
+                 return (Italic xs)
+
+      apos3 = do apos 3
+                 xs <- many1 $ inlineElement cmdTypeOf
+                 apos 3
+                 return (Bold xs)
+
+      apos4 = apos 4 >> return (Text "'")
+
+      apos5 = do apos 5
+                 xs <- many1 $ inlineElement cmdTypeOf
+                 apos 5
+                 return (Italic [Bold xs])
+
+      apos :: Int -> Parser ()
+      apos n = count n (char '\'') >> notFollowedBy (char '\'')
+
+
+objLink :: Parser InlineElement
+objLink = do try (string "[[[")
+             page  <- many1 (noneOf "|]")
+             label <- option Nothing
+                      (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
+             string "]]]"
+             return $ ObjectLink page label
+          <?>
+          "object link"
 
 
 pageLink :: Parser InlineElement
-pageLink = do string "[["
+pageLink = do try (string "[[")
               page     <- option Nothing 
-                          (many1 (noneOf "#|]") >>= return . Just)
+                          (liftM Just (many1 (noneOf "#|]")))
               fragment <- option Nothing
-                          (char '#' >> many1 (noneOf "|]") >>= return . Just)
-              text     <- option Nothing
-                          (char '|' >> many1 (noneOf "]") >>= return . Just)
+                          (liftM Just (char '#' >> many1 (noneOf "|]")))
+              label    <- option Nothing
+                          (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
 
               case (page, fragment) of
                 (Nothing, Nothing) -> pzero
                 (_, _)             -> return ()
 
               string "]]"
-              return $ PageLink page fragment text
+              return $ PageLink page fragment label
            <?>
            "page link"
 
 
+extLink :: Parser InlineElement
+extLink = do char '['
+             uriStr <- many1 (noneOf " \t]")
+             skipMany (oneOf " \t")
+             label  <- option Nothing
+                       (liftM Just (many1 (noneOf "]")))
+             
+             case parseURI uriStr of
+               Just uri -> char ']' >> return (ExternalLink uri label)
+               Nothing  -> pzero <?> "absolute URI"
+          <?>
+          "external link"
+
+
+inlineCmd :: CommandTypeOf -> Parser InlineElement
+inlineCmd cmdTypeOf
+    = (try $ do (tagName, tagAttrs) <- openTag
+                case cmdTypeOf tagName of
+                  Just InlineCommandType
+                      -> do xs <- contents
+                            closeTag tagName
+                            return $ InlineCmd InlineCommand {
+                                         iCmdName       = tagName
+                                       , iCmdAttributes = tagAttrs
+                                       , iCmdContents   = xs
+                                       }
+                  _   -> pzero
+      )
+      <|>
+      (try $ do (tagName, tagAttrs) <- emptyTag
+                case cmdTypeOf tagName of
+                  Just InlineCommandType
+                      -> return $ InlineCmd InlineCommand {
+                                         iCmdName       = tagName
+                                       , iCmdAttributes = tagAttrs
+                                       , iCmdContents   = []
+                                       }
+                  _   -> pzero
+      )
+      <?>
+      "inline command"
+    where
+      contents :: Parser [InlineElement]
+      contents = do x  <- inlineElement cmdTypeOf
+                    xs <- contents
+                    return (x:xs)
+                 <|>
+                 (comment >> contents)
+                 <|>
+                 liftM (Text "\n" :) (newline >> contents)
+                 <|>
+                 return []
+
+
+openTag :: Parser (String, [Attribute])
+openTag = try $ do char '<'
+                   many space
+                   name  <- many1 letter
+                   many space
+                   attrs <- many $ do attr <- tagAttr
+                                      many space
+                                      return attr
+                   char '>'
+                   return (name, attrs)
+
+
+emptyTag :: Parser (String, [Attribute])
+emptyTag = try $ do char '<'
+                    many space
+                    name  <- many1 letter
+                    many space
+                    attrs <- many $ do attr <- tagAttr
+                                       many space
+                                       return attr
+                    char '/'
+                    many space
+                    char '>'
+                    return (name, attrs)
+
+
+closeTag :: String -> Parser ()
+closeTag name = try $ do char '<'
+                         many space
+                         char '/'
+                         many space
+                         string name
+                         many space
+                         char '>'
+                         return ()
+
+
+tagAttr :: Parser (String, String)
+tagAttr = do name  <- many1 letter
+             char '='
+             char '"'
+             value <- many (satisfy (/= '"'))
+             char '"'
+             return (name, value)
+
+
 comment :: Parser ()
 comment = (try (string "<!--") >> skipTillEnd 1)
           <?>
           "comment"
     where
       skipTillEnd :: Int -> Parser ()
-      skipTillEnd level = ( (try (string "<!--") >> skipTillEnd (level + 1))
-                            <|>
-                            (try (string "-->") >> case level of
-                                                     1 -> return ()
-                                                     n -> skipTillEnd (n - 1))
-                            <|>
-                            (anyChar >> skipTillEnd level)
-                          )
+      skipTillEnd level = (try (string "<!--") >> skipTillEnd (level + 1))
+                          <|>
+                          (try (string "-->") >> case level of
+                                                   1 -> return ()
+                                                   n -> skipTillEnd (n - 1))
+                          <|>
+                          (anyChar >> skipTillEnd level)
 
 
 blockSymbols :: [Char]
-blockSymbols = " =-*#;"
+blockSymbols = " =-*#;<"
 
 
 inlineSymbols :: [Char]
-inlineSymbols = "<["
+inlineSymbols = "<[:'"
 
 -- white space
 ws :: Parser ()
@@ -272,7 +496,6 @@ ws = skipMany ( (oneOf " \t" >> return ())
 
 -- end of line
 eol :: Parser ()
-eol = ( (newline >> return ())
-        <|>
-        eof
-      )
+eol = (newline >> return ())
+      <|>
+      eof