d9751f9 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Merge pull request #1457 from mpickering/generalstate

d9751f9John MacFarlane12 years ago

src/Text/Pandoc/Parsing.hs+53−40

compare with master

unifiedsplit

@@ -2,6 +2,7 @@

2 FlexibleContexts

3, GeneralizedNewtypeDeriving

4, TypeSynonymInstances

5+, MultiParamTypeClasses

5, FlexibleInstances #-}

6, FlexibleInstances #-}

6{-

7{-

@@ -80,6 +81,7 @@ module Text.Pandoc.Parsing ( anyLine,

80 HeaderType (..),

81 HeaderType (..),

81 ParserContext (..),

82 ParserContext (..),

82 QuoteContext (..),

83 QuoteContext (..),

84+ HasQuoteContext (..),

83 NoteTable,

85 NoteTable,

84 NoteTable',

86 NoteTable',

85 KeyTable,

87 KeyTable,

@@ -88,7 +90,6 @@ module Text.Pandoc.Parsing ( anyLine,

88 toKey,

90 toKey,

89 registerHeader,

91 registerHeader,

90 smartPunctuation,

92 smartPunctuation,

91− withQuoteContext,

92 singleQuoteStart,

93 singleQuoteStart,

93 singleQuoteEnd,

94 singleQuoteEnd,

94 doubleQuoteStart,

95 doubleQuoteStart,

@@ -106,6 +107,7 @@ module Text.Pandoc.Parsing ( anyLine,

106 runF,

107 runF,

107 askF,

108 askF,

108 asksF,

109 asksF,

110+ token,

109 -- * Re-exports from Text.Pandoc.Parsec

111 -- * Re-exports from Text.Pandoc.Parsec

110 Stream,

112 Stream,

111 runParser,

113 runParser,

@@ -160,7 +162,6 @@ module Text.Pandoc.Parsing ( anyLine,

160 setSourceColumn,

162 setSourceColumn,

161 setSourceLine,

163 setSourceLine,

162 newPos,

164 newPos,

163− token

164 )

165 )

165where

166where

166

167

@@ -170,7 +171,7 @@ import Text.Pandoc.Builder (Blocks, Inlines, rawBlock, HasMeta(..))

170import qualified Text.Pandoc.Builder as B

171import qualified Text.Pandoc.Builder as B

171import Text.Pandoc.XML (fromEntities)

172import Text.Pandoc.XML (fromEntities)

172import qualified Text.Pandoc.UTF8 as UTF8 (putStrLn)

173import qualified Text.Pandoc.UTF8 as UTF8 (putStrLn)

173−import Text.Parsec

174+import Text.Parsec hiding (token)

174import Text.Parsec.Pos (newPos)

175import Text.Parsec.Pos (newPos)

175import Data.Char ( toLower, toUpper, ord, chr, isAscii, isAlphaNum,

176import Data.Char ( toLower, toUpper, ord, chr, isAscii, isAlphaNum,

176 isHexDigit, isSpace )

177 isHexDigit, isSpace )

@@ -484,7 +485,8 @@ mathDisplayWith op cl = try $ do

484 string op

485 string op

485 many1Till (noneOf "\n" <|> (newline <* notFollowedBy' blankline)) (try $ string cl)

486 many1Till (noneOf "\n" <|> (newline <* notFollowedBy' blankline)) (try $ string cl)

486

487

487−mathDisplay :: Stream s m Char => ParserT s ParserState m String

488+mathDisplay :: (HasReaderOptions st, Stream s m Char)

489+ => ParserT s st m String

488mathDisplay =

490mathDisplay =

489 (guardEnabled Ext_tex_math_dollars >> mathDisplayWith "$$" "$$")

491 (guardEnabled Ext_tex_math_dollars >> mathDisplayWith "$$" "$$")

490 <|> (guardEnabled Ext_tex_math_single_backslash >>

492 <|> (guardEnabled Ext_tex_math_single_backslash >>

@@ -492,7 +494,8 @@ mathDisplay =

492 <|> (guardEnabled Ext_tex_math_double_backslash >>

494 <|> (guardEnabled Ext_tex_math_double_backslash >>

493 mathDisplayWith "\\\\[" "\\\\]")

495 mathDisplayWith "\\\\[" "\\\\]")

494

496

495−mathInline :: Stream s m Char => ParserT s ParserState m String

497+mathInline :: (HasReaderOptions st , Stream s m Char)

498+ => ParserT s st m String

496mathInline =

499mathInline =

497 (guardEnabled Ext_tex_math_dollars >> mathInlineWith "$" "$")

500 (guardEnabled Ext_tex_math_dollars >> mathInlineWith "$" "$")

498 <|> (guardEnabled Ext_tex_math_single_backslash >>

501 <|> (guardEnabled Ext_tex_math_single_backslash >>

@@ -909,6 +912,21 @@ class HasReaderOptions st where

909 -- default

912 -- default

910 getOption f = (f . extractReaderOptions) <$> getState

913 getOption f = (f . extractReaderOptions) <$> getState

911

914

915+class HasQuoteContext st m where

916+ getQuoteContext :: (Stream s m t) => ParsecT s st m QuoteContext

917+ withQuoteContext :: QuoteContext -> ParsecT s st m a -> ParsecT s st m a

918+

919+instance Monad m => HasQuoteContext ParserState m where

920+ getQuoteContext = stateQuoteContext <$> getState

921+ withQuoteContext context parser = do

922+ oldState <- getState

923+ let oldQuoteContext = stateQuoteContext oldState

924+ setState oldState { stateQuoteContext = context }

925+ result <- parser

926+ newState <- getState

927+ setState newState { stateQuoteContext = oldQuoteContext }

928+ return result

929+

912instance HasReaderOptions ParserState where

930instance HasReaderOptions ParserState where

913 extractReaderOptions = stateOptions

931 extractReaderOptions = stateOptions

914

932

@@ -1051,9 +1069,9 @@ registerHeader (ident,classes,kvs) header' = do

1051failUnlessSmart :: (Stream s m a, HasReaderOptions st) => ParserT s st m ()

1069failUnlessSmart :: (Stream s m a, HasReaderOptions st) => ParserT s st m ()

1052failUnlessSmart = getOption readerSmart >>= guard

1070failUnlessSmart = getOption readerSmart >>= guard

1053

1071

1054−smartPunctuation :: Stream s m Char

1072+smartPunctuation :: (HasReaderOptions st, HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)

1055− => ParserT s ParserState m Inlines

1073+ => ParserT s st m Inlines

1056− -> ParserT s ParserState m Inlines

1074+ -> ParserT s st m Inlines

1057smartPunctuation inlineParser = do

1075smartPunctuation inlineParser = do

1058 failUnlessSmart

1076 failUnlessSmart

1059 choice [ quoted inlineParser, apostrophe, dash, ellipses ]

1077 choice [ quoted inlineParser, apostrophe, dash, ellipses ]

@@ -1061,46 +1079,33 @@ smartPunctuation inlineParser = do

1061apostrophe :: Stream s m Char => ParserT s st m Inlines

1079apostrophe :: Stream s m Char => ParserT s st m Inlines

1062apostrophe = (char '\'' <|> char '\8217') >> return (B.str "\x2019")

1080apostrophe = (char '\'' <|> char '\8217') >> return (B.str "\x2019")

1063

1081

1064−quoted :: Stream s m Char

1082+quoted :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)

1065− => ParserT s ParserState m Inlines

1083+ => ParserT s st m Inlines

1066− -> ParserT s ParserState m Inlines

1084+ -> ParserT s st m Inlines

1067quoted inlineParser = doubleQuoted inlineParser <|> singleQuoted inlineParser

1085quoted inlineParser = doubleQuoted inlineParser <|> singleQuoted inlineParser

1068

1086

1069−withQuoteContext :: Stream s m t

1070− => QuoteContext

1071− -> ParserT s ParserState m a

1072− -> ParserT s ParserState m a

1073−withQuoteContext context parser = do

1074− oldState <- getState

1075− let oldQuoteContext = stateQuoteContext oldState

1076− setState oldState { stateQuoteContext = context }

1077− result <- parser

1078− newState <- getState

1079− setState newState { stateQuoteContext = oldQuoteContext }

1080− return result

1081−

1082−singleQuoted :: Stream s m Char

1087+singleQuoted :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)

1083− => ParserT s ParserState m Inlines

1088+ => ParserT s st m Inlines

1084− -> ParserT s ParserState m Inlines

1089+ -> ParserT s st m Inlines

1085singleQuoted inlineParser = try $ do

1090singleQuoted inlineParser = try $ do

1086 singleQuoteStart

1091 singleQuoteStart

1087 withQuoteContext InSingleQuote $ many1Till inlineParser singleQuoteEnd >>=

1092 withQuoteContext InSingleQuote $ many1Till inlineParser singleQuoteEnd >>=

1088 return . B.singleQuoted . mconcat

1093 return . B.singleQuoted . mconcat

1089

1094

1090−doubleQuoted :: Stream s m Char

1095+doubleQuoted :: (HasQuoteContext st m, Stream s m Char)

1091− => ParserT s ParserState m Inlines

1096+ => ParserT s st m Inlines

1092− -> ParserT s ParserState m Inlines

1097+ -> ParserT s st m Inlines

1093doubleQuoted inlineParser = try $ do

1098doubleQuoted inlineParser = try $ do

1094 doubleQuoteStart

1099 doubleQuoteStart

1095 withQuoteContext InDoubleQuote $ manyTill inlineParser doubleQuoteEnd >>=

1100 withQuoteContext InDoubleQuote $ manyTill inlineParser doubleQuoteEnd >>=

1096 return . B.doubleQuoted . mconcat

1101 return . B.doubleQuoted . mconcat

1097

1102

1098−failIfInQuoteContext :: Stream s m t

1103+failIfInQuoteContext :: (HasQuoteContext st m, Stream s m t)

1099 => QuoteContext

1104 => QuoteContext

1100− -> ParserT s ParserState m ()

1105+ -> ParserT s st m ()

1101failIfInQuoteContext context = do

1106failIfInQuoteContext context = do

1102− st <- getState

1107+ context' <- getQuoteContext

1103− if stateQuoteContext st == context

1108+ if context' == context

1104 then fail "already inside quotes"

1109 then fail "already inside quotes"

1105 else return ()

1110 else return ()

1106

1111

@@ -1110,8 +1115,8 @@ charOrRef cs =

1110 guard (c `elem` cs)

1115 guard (c `elem` cs)

1111 return c)

1116 return c)

1112

1117

1113−singleQuoteStart :: Stream s m Char

1118+singleQuoteStart :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)

1114− => ParserT s ParserState m ()

1119+ => ParserT s st m ()

1115singleQuoteStart = do

1120singleQuoteStart = do

1116 failIfInQuoteContext InSingleQuote

1121 failIfInQuoteContext InSingleQuote

1117 -- single quote start can't be right after str

1122 -- single quote start can't be right after str

@@ -1124,8 +1129,8 @@ singleQuoteEnd = try $ do

1124 charOrRef "'\8217\146"

1129 charOrRef "'\8217\146"

1125 notFollowedBy alphaNum

1130 notFollowedBy alphaNum

1126

1131

1127−doubleQuoteStart :: Stream s m Char

1132+doubleQuoteStart :: (HasQuoteContext st m, Stream s m Char)

1128− => ParserT s ParserState m ()

1133+ => ParserT s st m ()

1129doubleQuoteStart = do

1134doubleQuoteStart = do

1130 failIfInQuoteContext InDoubleQuote

1135 failIfInQuoteContext InDoubleQuote

1131 try $ do charOrRef "\"\8220\147"

1136 try $ do charOrRef "\"\8220\147"

@@ -1179,6 +1184,14 @@ citeKey = try $ do

1179 let key = firstChar:rest

1184 let key = firstChar:rest

1180 return (suppress_author, key)

1185 return (suppress_author, key)

1181

1186

1187+

1188+token :: (Stream s m t)

1189+ => (t -> String)

1190+ -> (t -> SourcePos)

1191+ -> (t -> Maybe a)

1192+ -> ParsecT s st m a

1193+token pp pos match = tokenPrim pp (\_ t _ -> pos t) match

1194+

1182--

1195--

1183-- Macros

1196-- Macros

1184--

1197--

@@ -1200,9 +1213,9 @@ macro = do

1200 else return $ rawBlock "latex" def'

1213 else return $ rawBlock "latex" def'

1201

1214

1202-- | Apply current macros to string.

1215-- | Apply current macros to string.

1203−applyMacros' :: Stream [Char] m Char

1216+applyMacros' :: (HasReaderOptions st, HasMacros st, Stream [Char] m Char)

1204 => String

1217 => String

1205− -> ParserT [Char] ParserState m String

1218+ -> ParserT [Char] st m String

1206applyMacros' target = do

1219applyMacros' target = do

1207 apply <- getOption readerApplyMacros

1220 apply <- getOption readerApplyMacros

1208 if apply

1221 if apply

src/Text/Pandoc/Readers/HTML.hs+61−18

@@ -1,3 +1,4 @@

1+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}

1{-

2{-

@@ -40,7 +41,7 @@ import Text.HTML.TagSoup

40import Text.HTML.TagSoup.Match

41import Text.HTML.TagSoup.Match

41import Text.Pandoc.Definition

42import Text.Pandoc.Definition

42import qualified Text.Pandoc.Builder as B

43import qualified Text.Pandoc.Builder as B

43−import Text.Pandoc.Builder (Blocks, Inlines, trimInlines)

44+import Text.Pandoc.Builder (HasMeta (..), Blocks, Inlines, trimInlines)

44import Text.Pandoc.Shared

45import Text.Pandoc.Shared

45import Text.Pandoc.Options

46import Text.Pandoc.Options

46import Text.Pandoc.Parsing

47import Text.Pandoc.Parsing

@@ -52,6 +53,8 @@ import Control.Applicative ( (<$>), (<$), (<*) )

52import Data.Monoid

53import Data.Monoid

53import Text.Printf (printf)

54import Text.Printf (printf)

54import Debug.Trace (trace)

55import Debug.Trace (trace)

56+import Data.Default (Default (..))

57+import Control.Monad.Reader (Reader, runReader, asks, local, ask)

56isSpace :: Char -> Bool

59isSpace :: Char -> Bool

57isSpace ' ' = True

60isSpace ' ' = True

@@ -64,17 +67,26 @@ readHtml :: ReaderOptions -- ^ Reader options

64 -> String -- ^ String to parse (assumes @'\n'@ line endings)

67 -> String -- ^ String to parse (assumes @'\n'@ line endings)

65 -> Pandoc

68 -> Pandoc

66readHtml opts inp =

69readHtml opts inp =

67− case runParser parseDoc def{ stateOptions = opts } "source" tags of

70+ case flip runReader def $ runParserT parseDoc (HTMLState def{ stateOptions = opts } ) "source" tags of

68 Left err' -> error $ "\nError at " ++ show err'

71 Left err' -> error $ "\nError at " ++ show err'

69 Right result -> result

72 Right result -> result

70 where tags = canonicalizeTags $

73 where tags = canonicalizeTags $

71 parseTagsOptions parseOptions{ optTagPosition = True } inp

74 parseTagsOptions parseOptions{ optTagPosition = True } inp

72 parseDoc = do

75 parseDoc = do

73 blocks <- (fixPlains False) . mconcat <$> manyTill block eof

76 blocks <- (fixPlains False) . mconcat <$> manyTill block eof

74− meta <- stateMeta <$> getState

77+ meta <- stateMeta . parserState <$> getState

75 return $ Pandoc meta (B.toList blocks)

78 return $ Pandoc meta (B.toList blocks)

80+data HTMLState =

81+ HTMLState

82+ { parserState :: ParserState

83+ }

84+

85+data HTMLLocal = HTMLLocal { quoteContext :: QuoteContext }

86+

87+type HTMLParser s = ParserT s HTMLState (Reader HTMLLocal)

88+

77−type TagParser = Parser [Tag String] ParserState

89+type TagParser = HTMLParser [Tag String]

79pBody :: TagParser Blocks

91pBody :: TagParser Blocks

80pBody = pInTags "body" block

92pBody = pInTags "body" block

@@ -115,7 +127,6 @@ block = do

115 (take 60 $ show $ B.toList res)) (return ())

127 (take 60 $ show $ B.toList res)) (return ())

116 return res

128 return res

117

129

118−

119pList :: TagParser Blocks

130pList :: TagParser Blocks

120pList = pBulletList <|> pOrderedList <|> pDefinitionList

131pList = pBulletList <|> pOrderedList <|> pDefinitionList

121

132

@@ -365,8 +376,8 @@ pSelfClosing f g = do

365

376

366pQ :: TagParser Inlines

377pQ :: TagParser Inlines

367pQ = do

378pQ = do

368− quoteContext <- stateQuoteContext `fmap` getState

379+ context <- asks quoteContext

369− let quoteType = case quoteContext of

380+ let quoteType = case context of

370 InDoubleQuote -> SingleQuote

381 InDoubleQuote -> SingleQuote

371 _ -> DoubleQuote

382 _ -> DoubleQuote

372 let innerQuoteContext = if quoteType == SingleQuote

383 let innerQuoteContext = if quoteType == SingleQuote

@@ -477,7 +488,8 @@ pTagText :: TagParser Inlines

477pTagText = try $ do

488pTagText = try $ do

478 (TagText str) <- pSatisfy isTagText

489 (TagText str) <- pSatisfy isTagText

479 st <- getState

490 st <- getState

491+ qu <- ask

480− case runParser (many pTagContents) st "text" str of

492+ case flip runReader qu $ runParserT (many pTagContents) st "text" str of

481 Left _ -> fail $ "Could not parse `" ++ str ++ "'"

493 Left _ -> fail $ "Could not parse `" ++ str ++ "'"

482 Right result -> return $ mconcat result

494 Right result -> return $ mconcat result

483

495

@@ -486,7 +498,9 @@ pBlank = try $ do

486 (TagText str) <- pSatisfy isTagText

498 (TagText str) <- pSatisfy isTagText

487 guard $ all isSpace str

499 guard $ all isSpace str

488

500

501+type InlinesParser = HTMLParser String

502+

489−pTagContents :: Parser [Char] ParserState Inlines

503+pTagContents :: InlinesParser Inlines

490pTagContents =

504pTagContents =

491 B.displayMath <$> mathDisplay

505 B.displayMath <$> mathDisplay

492 <|> B.math <$> mathInline

506 <|> B.math <$> mathInline

@@ -496,12 +510,11 @@ pTagContents =

496 <|> pSymbol

510 <|> pSymbol

497 <|> pBad

511 <|> pBad

498

512

499−pStr :: Parser [Char] ParserState Inlines

513+pStr :: InlinesParser Inlines

500pStr = do

514pStr = do

501 result <- many1 $ satisfy $ \c ->

515 result <- many1 $ satisfy $ \c ->

502 not (isSpace c) && not (isSpecial c) && not (isBad c)

516 not (isSpace c) && not (isSpecial c) && not (isBad c)

503− pos <- getPosition

517+ updateLastStrPos

504− updateState $ \s -> s{ stateLastStrPos = Just pos }

505 return $ B.str result

518 return $ B.str result

506

519

507isSpecial :: Char -> Bool

520isSpecial :: Char -> Bool

@@ -516,13 +529,13 @@ isSpecial '\8220' = True

516isSpecial '\8221' = True

529isSpecial '\8221' = True

517isSpecial _ = False

530isSpecial _ = False

518

531

519−pSymbol :: Parser [Char] ParserState Inlines

532+pSymbol :: InlinesParser Inlines

520pSymbol = satisfy isSpecial >>= return . B.str . (:[])

533pSymbol = satisfy isSpecial >>= return . B.str . (:[])

521

534

522isBad :: Char -> Bool

535isBad :: Char -> Bool

523isBad c = c >= '\128' && c <= '\159' -- not allowed in HTML

536isBad c = c >= '\128' && c <= '\159' -- not allowed in HTML

524

537

525−pBad :: Parser [Char] ParserState Inlines

538+pBad :: InlinesParser Inlines

526pBad = do

539pBad = do

527 c <- satisfy isBad

540 c <- satisfy isBad

528 let c' = case c of

541 let c' = case c of

@@ -556,7 +569,7 @@ pBad = do

556 _ -> '?'

569 _ -> '?'

557 return $ B.str [c']

570 return $ B.str [c']

558

571

559−pSpace :: Parser [Char] ParserState Inlines

572+pSpace :: InlinesParser Inlines

560pSpace = many1 (satisfy isSpace) >> return B.space

573pSpace = many1 (satisfy isSpace) >> return B.space

561

574

562--

575--

@@ -672,19 +685,23 @@ _ `closes` _ = False

672--- parsers for use in markdown, textile readers

685--- parsers for use in markdown, textile readers

673

686

674-- | Matches a stretch of HTML in balanced tags.

687-- | Matches a stretch of HTML in balanced tags.

675−htmlInBalanced :: (Tag String -> Bool) -> Parser [Char] ParserState String

688+htmlInBalanced :: (Monad m)

689+ => (Tag String -> Bool)

690+ -> ParserT String st m String

676htmlInBalanced f = try $ do

691htmlInBalanced f = try $ do

677 (TagOpen t _, tag) <- htmlTag f

692 (TagOpen t _, tag) <- htmlTag f

678 guard $ '/' `notElem` tag -- not a self-closing tag

693 guard $ '/' `notElem` tag -- not a self-closing tag

679 let stopper = htmlTag (~== TagClose t)

694 let stopper = htmlTag (~== TagClose t)

680− let anytag = liftM snd $ htmlTag (const True)

695+ let anytag = snd <$> htmlTag (const True)

681 contents <- many $ notFollowedBy' stopper >>

696 contents <- many $ notFollowedBy' stopper >>

682 (htmlInBalanced f <|> anytag <|> count 1 anyChar)

697 (htmlInBalanced f <|> anytag <|> count 1 anyChar)

683 endtag <- liftM snd stopper

698 endtag <- liftM snd stopper

684 return $ tag ++ concat contents ++ endtag

699 return $ tag ++ concat contents ++ endtag

685

700

686-- | Matches a tag meeting a certain condition.

701-- | Matches a tag meeting a certain condition.

702+htmlTag :: Monad m

703+ => (Tag String -> Bool)

687−htmlTag :: (Tag String -> Bool) -> Parser [Char] st (Tag String, String)

704+ -> ParserT [Char] st m (Tag String, String)

688htmlTag f = try $ do

705htmlTag f = try $ do

689 lookAhead $ char '<' >> (oneOf "/!?" <|> letter)

706 lookAhead $ char '<' >> (oneOf "/!?" <|> letter)

690 (next : _) <- getInput >>= return . canonicalizeTags . parseTags

707 (next : _) <- getInput >>= return . canonicalizeTags . parseTags

@@ -707,3 +724,29 @@ mkAttr attr = (attribsId, attribsClasses, attribsKV)

707 attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr

724 attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr

708

725

709

726

727+-- Instances

728+

729+-- This signature should be more general

730+-- MonadReader HTMLLocal m => HasQuoteContext st m

731+instance HasQuoteContext st (Reader HTMLLocal) where

732+ getQuoteContext = asks quoteContext

733+ withQuoteContext q = local (\s -> s{quoteContext = q})

734+

735+instance HasReaderOptions HTMLState where

736+ extractReaderOptions = extractReaderOptions . parserState

737+

738+instance Default HTMLState where

739+ def = HTMLState def

740+

741+instance HasMeta HTMLState where

742+ setMeta s b st = st {parserState = setMeta s b $ parserState st}

743+ deleteMeta s st = st {parserState = deleteMeta s $ parserState st}

744+

745+instance Default HTMLLocal where

746+ def = HTMLLocal NoQuote

747+

748+instance HasLastStrPosition HTMLState where

749+ setLastStrPos s st = st {parserState = setLastStrPos s (parserState st)}

750+ getLastStrPos = getLastStrPos . parserState

751+

752+