+horizontalLine :: Parser BlockElement
+horizontalLine = try ( do count 4 (char '-')
+ many (char '-')
+ ws
+ eol
+ return HorizontalLine
+ )
+ <?>
+ "horizontal line"
+
+
+listElement :: CommandTypeOf -> Parser BlockElement
+listElement cmdTypeOf = listElement' [] >>= return . List
+ where
+ listElement' :: [Char] -> Parser ListElement
+ listElement' stack
+ = do t <- oneOf "*#"
+ ws
+ xs <- items (stack ++ [t])
+ return (ListElement (toType t) xs)
+
+ -- ListItem の終了條件は、
+ items :: [Char] -> Parser [ListItem]
+ items stack = do xs <- many1 $ inlineElement cmdTypeOf
+ nested <- option Nothing
+ $ try $ do skipMany comment
+ newline
+ string stack
+ listElement' stack >>= return . Just
+ rest <- items stack
+ return $ (map Right xs ++ map Left (catMaybes [nested])) : rest
+ <|>
+ (try $ do skipMany comment
+ newline
+ string stack
+ ws
+ items stack
+ )
+ <|>
+ return []
+
+ toType :: Char -> ListType
+ toType '*' = Bullet
+ toType '#' = Numbered
+
+
+definitionList :: CommandTypeOf -> Parser BlockElement
+definitionList cmdTypeOf = many1 definition >>= return . DefinitionList
+ where
+ definition :: Parser Definition
+ definition = do char ';'
+ ws
+ tHead <- inlineElement cmdTypeOf
+ 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 cmdTypeOf
+ xs <- term
+ return (x:xs)
+ <?>
+ "term to be defined"
+
+ description :: Parser [InlineElement]
+ description = do x <- inlineElement cmdTypeOf
+ xs <- description
+ return (x:xs)
+ <|>
+ try ( do newline
+ char ':'
+ ws
+ xs <- description
+ return (Text "\n" : xs)
+ )
+ <|>
+ (newline >> return [])
+ <|>
+ (eof >> return [])
+ <?>
+ "description of term"
+
+
+pdata :: Parser BlockElement
+pdata = do try (string "<![PDATA[")
+ many (oneOf " \t\n")
+ x <- pdata'
+ return (Preformatted [Text x])
+ where
+ pdata' :: Parser String
+ pdata' = do try (many (oneOf " \t\n") >> string "]]>")
+ return []
+ <|>
+ do x <- anyChar
+ xs <- pdata'
+ return (x:xs)
+
+
+leadingSpaced :: CommandTypeOf -> Parser BlockElement
+leadingSpaced cmdTypeOf = (char ' ' >> leadingSpaced' >>= return . Preformatted)
+ <?>
+ "leading space"
+ where
+ leadingSpaced' :: Parser [InlineElement]
+ leadingSpaced' = do x <- inlineElement cmdTypeOf
+ xs <- leadingSpaced'
+ return (x:xs)
+ <|>
+ try ( newline
+ >>
+ char ' '
+ >>
+ leadingSpaced'
+ >>=
+ return . (Text "\n" :)
+ )
+ <|>
+ return []
+
+
+blockCommand :: Parser BlockElement
+blockCommand = pzero -- not implemented
+
+
+paragraph :: CommandTypeOf -> Parser BlockElement
+paragraph cmdTypeOf = paragraph' >>= return . Paragraph
+ where
+ paragraph' :: Parser [InlineElement]
+ paragraph' = do x <- inlineElement cmdTypeOf
+ xs <- try ( do newline
+ eof
+ return []
+ -- \n で文字列が終はってゐたら、ここ
+ -- で終了。
+ )
+ <|>
+ try ( do newline
+ ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
+ ys <- (paragraph' <|> return [])
+ return (Text "\n" : ys)
+ -- \n があり、その次に \n または
+ -- blockSymbols があれば、fail して
+ -- 最初の newline を讀んだ所まで卷き
+ -- 戻す。
+ )
+ <|>
+ paragraph'
+ -- それ以外の場合は次の inlineElement から
+ -- を讀んで見る。但し一つも無くても良い。
+ <|>
+ return [] -- 全部失敗したらここで終了。
+ 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.")
+ ]
+ ]