5e2d22a · typeable/pandoc

git.iko.soy/typeable/pandoc

Generalised more in Parsing.hs to enable the use of custom state

commit5e2d22a27e231f0ac62739b3bcd15b548c782f25 authorMatthew Pickering <matthewtpickering@gmail.com> dateSat 26 Jul 2014, 17:34 (12 years ago) parent18f4490

2 files changed+114−58

compare with master

unifiedsplit

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

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

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

22 FlexibleContexts

33, GeneralizedNewtypeDeriving

44, TypeSynonymInstances

5+, MultiParamTypeClasses

56, FlexibleInstances #-}

67{-

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

8081 HeaderType (..),

8182 ParserContext (..),

8283 QuoteContext (..),

84+ HasQuoteContext (..),

8385 NoteTable,

8486 NoteTable',

8587 KeyTable,

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

8890 toKey,

8991 registerHeader,

9092 smartPunctuation,

91− withQuoteContext,

9293 singleQuoteStart,

9394 singleQuoteEnd,

9495 doubleQuoteStart,

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

106107 runF,

107108 askF,

108109 asksF,

110+ token,

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

110112 Stream,

111113 runParser,

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

160162 setSourceColumn,

161163 setSourceLine,

162164 newPos,

163− token

164165 )

165166where

166167

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

170171import qualified Text.Pandoc.Builder as B

171172import Text.Pandoc.XML (fromEntities)

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

173−import Text.Parsec

174+import Text.Parsec hiding (token)

174175import Text.Parsec.Pos (newPos)

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

176177 isHexDigit, isSpace )

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

484485 string op

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

486487

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

488490mathDisplay =

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

490492 <|> (guardEnabled Ext_tex_math_single_backslash >>

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

492494 <|> (guardEnabled Ext_tex_math_double_backslash >>

493495 mathDisplayWith "\\\\[" "\\\\]")

494496

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

496499mathInline =

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

498501 <|> (guardEnabled Ext_tex_math_single_backslash >>

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

909912 -- default

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

911914

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+

912930instance HasReaderOptions ParserState where

913931 extractReaderOptions = stateOptions

914932

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

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

10521070failUnlessSmart = getOption readerSmart >>= guard

10531071

1054−smartPunctuation :: Stream s m Char

1055− => ParserT s ParserState m Inlines

1056− -> ParserT s ParserState m Inlines

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

1073+ => ParserT s st m Inlines

1074+ -> ParserT s st m Inlines

10571075smartPunctuation inlineParser = do

10581076 failUnlessSmart

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

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

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

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

10631081

1064−quoted :: Stream s m Char

1065− => ParserT s ParserState m Inlines

1066− -> ParserT s ParserState m Inlines

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

1083+ => ParserT s st m Inlines

1084+ -> ParserT s st m Inlines

10671085quoted inlineParser = doubleQuoted inlineParser <|> singleQuoted inlineParser

10681086

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

1083− => ParserT s ParserState m Inlines

1084− -> ParserT s ParserState m Inlines

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

1088+ => ParserT s st m Inlines

1089+ -> ParserT s st m Inlines

10851090singleQuoted inlineParser = try $ do

10861091 singleQuoteStart

10871092 withQuoteContext InSingleQuote $ many1Till inlineParser singleQuoteEnd >>=

10881093 return . B.singleQuoted . mconcat

10891094

1090−doubleQuoted :: Stream s m Char

1091− => ParserT s ParserState m Inlines

1092− -> ParserT s ParserState m Inlines

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

1096+ => ParserT s st m Inlines

1097+ -> ParserT s st m Inlines

10931098doubleQuoted inlineParser = try $ do

10941099 doubleQuoteStart

10951100 withQuoteContext InDoubleQuote $ manyTill inlineParser doubleQuoteEnd >>=

10961101 return . B.doubleQuoted . mconcat

10971102

1098−failIfInQuoteContext :: Stream s m t

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

10991104 => QuoteContext

1100− -> ParserT s ParserState m ()

1105+ -> ParserT s st m ()

11011106failIfInQuoteContext context = do

1102− st <- getState

1103− if stateQuoteContext st == context

1107+ context' <- getQuoteContext

1108+ if context' == context

11041109 then fail "already inside quotes"

11051110 else return ()

11061111

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

11101115 guard (c `elem` cs)

11111116 return c)

11121117

1113−singleQuoteStart :: Stream s m Char

1114− => ParserT s ParserState m ()

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

1119+ => ParserT s st m ()

11151120singleQuoteStart = do

11161121 failIfInQuoteContext InSingleQuote

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

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

11241129 charOrRef "'\8217\146"

11251130 notFollowedBy alphaNum

11261131

1127−doubleQuoteStart :: Stream s m Char

1128− => ParserT s ParserState m ()

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

1133+ => ParserT s st m ()

11291134doubleQuoteStart = do

11301135 failIfInQuoteContext InDoubleQuote

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

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

11791184 let key = firstChar:rest

11801185 return (suppress_author, key)

11811186

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+

11821195--

11831196-- Macros

11841197--

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

12001213 else return $ rawBlock "latex" def'

12011214

12021215-- | Apply current macros to string.

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

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

12041217 => String

1205− -> ParserT [Char] ParserState m String

1218+ -> ParserT [Char] st m String

12061219applyMacros' target = do

12071220 apply <- getOption readerApplyMacros

12081221 if apply

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

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

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

12{-

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

4041import Text.HTML.TagSoup.Match

4142import Text.Pandoc.Definition

4243import qualified Text.Pandoc.Builder as B

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

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

4445import Text.Pandoc.Shared

4546import Text.Pandoc.Options

4647import Text.Pandoc.Parsing

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

5253import Data.Monoid

5354import Text.Printf (printf)

5455import Debug.Trace (trace)

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

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

5558

5659isSpace :: Char -> Bool

5760isSpace ' ' = True

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

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

6568 -> Pandoc

6669readHtml 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

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

6972 Right result -> result

7073 where tags = canonicalizeTags $

7174 parseTagsOptions parseOptions{ optTagPosition = True } inp

7275 parseDoc = do

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

74− meta <- stateMeta <$> getState

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

7578 return $ Pandoc meta (B.toList blocks)

7679

77−type TagParser = Parser [Tag String] ParserState

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+

89+type TagParser = HTMLParser [Tag String]

7890

7991pBody :: TagParser Blocks

8092pBody = pInTags "body" block

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

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

116128 return res

117129

118−

119130pList :: TagParser Blocks

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

121132

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

365376

366377pQ :: TagParser Inlines

367378pQ = do

368− quoteContext <- stateQuoteContext `fmap` getState

369− let quoteType = case quoteContext of

379+ context <- asks quoteContext

380+ let quoteType = case context of

370381 InDoubleQuote -> SingleQuote

371382 _ -> DoubleQuote

372383 let innerQuoteContext = if quoteType == SingleQuote

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

477488pTagText = try $ do

478489 (TagText str) <- pSatisfy isTagText

479490 st <- getState

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

491+ qu <- ask

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

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

482494 Right result -> return $ mconcat result

483495

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

486498 (TagText str) <- pSatisfy isTagText

487499 guard $ all isSpace str

488500

489−pTagContents :: Parser [Char] ParserState Inlines

501+type InlinesParser = HTMLParser String

502+

503+pTagContents :: InlinesParser Inlines

490504pTagContents =

491505 B.displayMath <$> mathDisplay

492506 <|> B.math <$> mathInline

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

496510 <|> pSymbol

497511 <|> pBad

498512

499−pStr :: Parser [Char] ParserState Inlines

513+pStr :: InlinesParser Inlines

500514pStr = do

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

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

503− pos <- getPosition

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

517+ updateLastStrPos

505518 return $ B.str result

506519

507520isSpecial :: Char -> Bool

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

516529isSpecial '\8221' = True

517530isSpecial _ = False

518531

519−pSymbol :: Parser [Char] ParserState Inlines

532+pSymbol :: InlinesParser Inlines

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

521534

522535isBad :: Char -> Bool

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

524537

525−pBad :: Parser [Char] ParserState Inlines

538+pBad :: InlinesParser Inlines

526539pBad = do

527540 c <- satisfy isBad

528541 let c' = case c of

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

556569 _ -> '?'

557570 return $ B.str [c']

558571

559−pSpace :: Parser [Char] ParserState Inlines

572+pSpace :: InlinesParser Inlines

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

561574

562575--

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

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

673686

674687-- | 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

676691htmlInBalanced f = try $ do

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

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

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

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

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

681696 contents <- many $ notFollowedBy' stopper >>

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

683698 endtag <- liftM snd stopper

684699 return $ tag ++ concat contents ++ endtag

685700

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

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

702+htmlTag :: Monad m

703+ => (Tag String -> Bool)

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

688705htmlTag f = try $ do

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

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

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

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

708725

709726

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+