+ leadingSpaced' :: Parser [InlineElement]
+ leadingSpaced' = do x <- inlineElement cmdTypeOf
+ xs <- leadingSpaced'
+ return (x:xs)
+ <|>
+ try ( liftM (Text "\n" :) ( newline
+ >>
+ char ' '
+ >>
+ leadingSpaced'
+ )
+ )
+ <|>
+ return []
+
+
+paragraph :: CommandTypeOf -> Parser BlockElement
+paragraph cmdTypeOf = liftM Paragraph 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 を讀んだ所まで卷き
+ -- 戻す。
+
+ -- FIXME: 本當にそのやうな動作になつ
+ -- てゐるか?偶然動いてゐるだけではな
+ -- いか?確かにこの實裝でユニットテス
+ -- トは通るのだが、私の理解を越えてし
+ -- まったやうだ。
+ )
+ <|>
+ 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 = ((:) <$> blockElement cmdTypeOf ⊛ contents)
+ <|>
+ (newline *> contents)
+ <|>
+ (comment *> contents)
+ <|>
+ pure []
+
+ undefinedCmdErr ∷ Text → 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 = Text ∘ T.pack <$> (try (string "<!nowiki[") *> nowiki')
+ where
+ nowiki' ∷ Parser String
+ nowiki' = (try (string "]>") *> pure [])
+ <|>
+ ((:) <$> anyChar ⊛ nowiki')
+
+text ∷ Parser InlineElement
+text = (Text ∘ T.pack ∘ (':' :) <$> ( char ':' *>
+ many (noneOf ('\n':inlineSymbols))
+ ))
+ -- 定義リストとの關係上、コロンは先頭にしか來られない。
+ <|>
+ (Text ∘ T.pack <$> (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 void $ try (string "[[[")
+ page ← many1 (noneOf "|]")
+ label ← option Nothing $
+ Just <$> (char '|' *> many1 (satisfy (≠ ']')))
+ void $ string "]]]"
+ pure $ ObjectLink (T.pack page) (T.pack <$> label)
+ <?>
+ "object link"
+
+pageLink ∷ Parser InlineElement
+pageLink = do void $ try (string "[[")
+ page ← option Nothing $
+ Just <$> many1 (noneOf "#|]")
+ fragment ← option Nothing $
+ Just <$> (char '#' *> many1 (noneOf "|]"))
+ label ← option Nothing $
+ Just <$> (char '|' *> many1 (satisfy (≠ ']')))
+ when (isNothing page ∧ isNothing fragment) (∅)
+ void $ string "]]"
+ pure $ PageLink (T.pack <$> page )
+ (T.pack <$> fragment)
+ (T.pack <$> label )