1{-# LANGUAGE CPP #-} 2{-# LANGUAGE RankNTypes #-} 3{-# LANGUAGE AllowAmbiguousTypes #-} 4{-# LANGUAGE FlexibleInstances #-} 5{-# LANGUAGE MultiParamTypeClasses #-} 6{-# LANGUAGE OverloadedStrings #-} 7{-# LANGUAGE ScopedTypeVariables #-} 8{-# LANGUAGE TupleSections #-} 9{-# LANGUAGE UndecidableInstances #-} 10{-# LANGUAGE BangPatterns #-} 11module Commonmark.Blocks 12 ( mkBlockParser 13 , defaultBlockSpecs 14 , BlockStartResult(..) 15 , BlockSpec(..) 16 , BlockData(..) 17 , defBlockData 18 , BlockNode 19 , BPState(..) 20 , BlockParser 21 , LinkInfo(..) 22 , defaultFinalizer 23 , runInlineParser 24 , addNodeToStack 25 , collapseNodeStack 26 , getBlockText 27 , removeIndent 28 , bspec 29 , endOfBlock 30 , interruptsParagraph 31 , linkReferenceDef 32 , renderChildren 33 , reverseSubforests 34 -- * BlockSpecs 35 , docSpec 36 , indentedCodeSpec 37 , fencedCodeSpec 38 , blockQuoteSpec 39 , atxHeadingSpec 40 , setextHeadingSpec 41 , thematicBreakSpec 42 , listItemSpec 43 , bulletListMarker 44 , orderedListMarker 45 , rawHtmlSpec 46 , attributeSpec 47 , paraSpec 48 , plainSpec 49 ) 50where 51 52import Commonmark.Tag 53import Commonmark.TokParsers 54import Commonmark.ReferenceMap 55import Commonmark.Inlines (pEscaped, pLinkDestination, 56 pLinkLabel, pLinkTitle) 57import Commonmark.Entity (unEntity) 58import Commonmark.Tokens 59import Commonmark.Types 60import Control.Monad (foldM, guard, mzero, void, unless, 61 when) 62import Control.Monad.Trans.Class (lift) 63import Data.Foldable (foldrM) 64#if !MIN_VERSION_base(4,11,0) 65import Data.Monoid 66#endif 67import Data.Char (isAsciiUpper, isDigit, isSpace) 68import Data.Dynamic 69import Data.Text (Text) 70import qualified Data.Map.Strict as M 71import qualified Data.Text as T 72import qualified Data.Text.Read as TR 73import Data.Tree 74import Text.Parsec 75 76mkBlockParser 77 :: (Monad m, IsBlock il bl) 78 => [BlockSpec m il bl] -- ^ Defines block syntax 79 -> [BlockParser m il bl bl] -- ^ Parsers to run at end 80 -> (ReferenceMap -> [Tok] -> m (Either ParseError il)) -- ^ Inline parser 81 -> [BlockParser m il bl Attributes] -- ^ attribute parsers 82 -> [Tok] -- ^ Tokenized commonmark input 83 -> m (Either ParseError bl) -- ^ Result or error 84mkBlockParser specs finalParsers ilParser attrParsers ts = 85 runParserT (do case ts of 86 (t:_) -> setPosition (tokPos t) 87 [] -> return () 88 processLines specs finalParsers) 89 BPState{ referenceMap = emptyReferenceMap 90 , inlineParser = ilParser 91 , nodeStack = [Node (defBlockData docSpec) []] 92 , blockMatched = False 93 , maybeLazy = True 94 , maybeBlank = True 95 , counters = M.empty 96 , failurePositions = M.empty 97 , attributeParsers = attrParsers 98 , nextAttributes = mempty 99 } 100 "source" (length ts `seq` ts) 101 -- we evaluate length ts to make sure the list is 102 -- fully evaluated; this helps performance. note that 103 -- we can't use deepseq because there's no instance for SourcePos. 104 105processLines :: (Monad m, IsBlock il bl) 106 => [BlockSpec m il bl] 107 -> [BlockParser m il bl bl] -- ^ Parsers to run at end 108 -> BlockParser m il bl bl 109processLines specs finalParsers = {-# SCC processLines #-} do 110 let go = eof <|> (processLine specs >> go) in go 111 tree <- (nodeStack <$> getState) >>= collapseNodeStack 112 updateState $ \st -> st{ nodeStack = [reverseSubforests tree] } 113 endContent <- mconcat <$> sequence finalParsers 114 tree':_ <- nodeStack <$> getState 115 body <- blockConstructor (blockSpec (rootLabel tree')) tree' 116 return $! body <> endContent 117 118reverseSubforests :: Tree a -> Tree a 119reverseSubforests (Node x cs) = Node x $ map reverseSubforests $ reverse cs 120 121processLine :: (Monad m, IsBlock il bl) 122 => [BlockSpec m il bl] -> BlockParser m il bl () 123processLine specs = do 124 -- check block continuations for each node in stack 125 st' <- getState 126 putState $ st'{ blockMatched = True 127 , maybeLazy = True 128 , maybeBlank = True 129 , failurePositions = M.empty } 130 (matched, unmatched) <- foldrM checkContinue ([],[]) (nodeStack st') 131 132 -- if not everything matched, and last unmatched is paragraph, 133 -- then we may have a lazy paragraph continuation 134 updateState $ \st -> st{ maybeLazy = maybeLazy st && 135 case unmatched of 136 m:_ -> blockParagraph (bspec m) 137 _ -> False } 138 139 -- close unmatched blocks 140 if null unmatched 141 then updateState $ \st -> st{ nodeStack = matched } 142 -- this update is needed or we lose startpos information 143 else case matched of 144 [] -> error "no blocks matched" 145 m:ms -> do 146 m' <- collapseNodeStack (unmatched ++ [m]) 147 updateState $ \st -> st{ nodeStack = m':ms } 148 149 restBlank <- option False $ True <$ lookAhead blankLine 150 151 {-# SCC block_starts #-} unless restBlank $ 152 (do skipMany1 (doBlockStarts specs) 153 optional (try (blockStart paraSpec))) 154 <|> 155 (do getState >>= guard . maybeLazy 156 -- lazy line 157 sp <- getPosition 158 updateState $ \st -> st{ nodeStack = 159 map (addStartPos sp) (unmatched ++ matched) }) 160 <|> 161 void (try (blockStart paraSpec)) 162 <|> 163 return () 164 165 (cur:rest) <- nodeStack <$> getState 166 -- add line contents 167 let curdata = rootLabel cur 168 when (blockParagraph (bspec cur)) $ skipMany spaceTok 169 pos <- getPosition 170 toks <- {-# SCC restOfLine #-} restOfLine 171 updateState $ \st -> st{ 172 nodeStack = 173 cur{ rootLabel = 174 if blockContainsLines (bspec cur) 175 then curdata{ blockLines = toks : blockLines curdata } 176 else 177 if maybeBlank st && restBlank 178 then curdata{ blockBlanks = sourceLine pos : 179 blockBlanks curdata } 180 else curdata 181 } : rest 182 } 183 -- showNodeStack 184 185addStartPos :: SourcePos -> BlockNode m il bl -> BlockNode m il bl 186addStartPos sp (Node bd cs) = Node bd{ blockStartPos = sp : blockStartPos bd } cs 187 188doBlockStarts :: Monad m => [BlockSpec m il bl] -> BlockParser m il bl () 189doBlockStarts specs = do 190 st' <- getState 191 initPos <- getPosition 192 let failurePosMap = failurePositions st' 193 let specs' = foldr (\spec sps -> 194 case M.lookup (blockType spec) failurePosMap of 195 Just pos' | initPos < pos' -> sps 196 _ -> spec:sps) [] specs 197 go initPos specs' 198 where 199 go _ [] = mzero 200 go initPos (spec:otherSpecs) = try (do 201 pst <- getParserState 202 res <- blockStart spec 203 case res of 204 BlockStartMatch -> return () 205 BlockStartNoMatchBefore pos -> do 206 setParserState pst 207 unless (pos == initPos) $ 208 updateState $ \st -> 209 st{ failurePositions = 210 M.insert (blockType spec) 211 pos (failurePositions st) } 212 go initPos otherSpecs) <|> go initPos otherSpecs 213 214checkContinue :: Monad m 215 => BlockNode m il bl 216 -> ([BlockNode m il bl],[BlockNode m il bl]) 217 -> BlockParser m il bl ([BlockNode m il bl],[BlockNode m il bl]) 218checkContinue nd (matched, unmatched) = do 219 ismatched <- blockMatched <$> getState 220 if ismatched 221 then 222 {-# SCC blockContinues #-} 223 (do (startpos, Node bdata children) <- blockContinue (bspec nd) nd 224 matched' <- blockMatched <$> getState 225 -- if blockContinue set blockMatched to False, it's 226 -- because of characters on the line closing the block, 227 -- so it's not to be counted as blank: 228 unless matched' $ 229 updateState $ \st -> st{ maybeBlank = False, 230 maybeLazy = False } 231 let new = Node bdata{ blockStartPos = 232 startpos : blockStartPos bdata 233 } children 234 return $! 235 if matched' 236 then (new:matched, unmatched) 237 else (matched, new:unmatched)) 238 <|> (matched, nd:unmatched) <$ updateState (\st -> st{ 239 blockMatched = False }) 240 else return $! (matched, nd:unmatched) 241 242 243{- 244--- for debugging 245showNodeStack :: Monad m => BlockParser m il bl a 246showNodeStack = do 247 ns <- nodeStack <$> getState 248 trace (unlines ("NODESTACK:" : map showNode ns)) (return $! ()) 249 return undefined 250 where 251 showNode (Node bdata children) = 252 unlines [ "-----" 253 , show (blockSpec bdata) 254 , show (blockStartPos bdata) 255 , show (length children) ] 256-} 257 258data BlockStartResult = 259 BlockStartMatch 260 | BlockStartNoMatchBefore !SourcePos 261 deriving (Show, Eq) 262 263-- | Defines a block-level element type. 264data BlockSpec m il bl = BlockSpec 265 { blockType :: !Text -- ^ Descriptive name of block type 266 , blockStart :: BlockParser m il bl BlockStartResult 267 -- ^ Parses beginning 268 -- of block. The parser should verify any 269 -- preconditions, parse the opening of the block, 270 -- and add the new block to the block stack using 271 -- 'addNodeToStack', returning 'BlockStartMatch' on 272 -- success. If the match fails, the parser can 273 -- either fail or return 'BlockStartNoMatchBefore' and a 274 -- 'SourcePos' before which the parser is known 275 -- not to succeed (this will be stored in 276 -- 'failurePositions' for the line, to ensure 277 -- that future matches won't be attempted until 278 -- after that position). 279 , blockCanContain :: BlockSpec m il bl -> Bool -- ^ Returns True if 280 -- this kind of block can contain the specified 281 -- block type. 282 , blockContainsLines :: !Bool -- ^ True if this kind of block 283 -- can contain text lines. 284 , blockParagraph :: !Bool -- ^ True if this kind of block 285 -- is paragraph. 286 , blockContinue :: BlockNode m il bl 287 -> BlockParser m il bl (SourcePos, BlockNode m il bl) 288 -- ^ Parser that checks to see if the current 289 -- block (the 'BlockNode') can be kept open. 290 -- If it fails, the block will be closed, unless 291 -- we have a lazy paragraph continuation within 292 -- the block. 293 , blockConstructor :: BlockNode m il bl -> BlockParser m il bl bl 294 -- ^ Renders the node into its target format, 295 -- possibly after rendering inline content. 296 , blockFinalize :: BlockNode m il bl -> BlockNode m il bl 297 -> BlockParser m il bl (BlockNode m il bl) 298 -- ^ Runs when the block is closed, but prior 299 -- to rendering. The first parameter is the 300 -- child, the second the parent. 301 } 302 303instance Show (BlockSpec m il bl) where 304 show bs = "<BlockSpec " ++ T.unpack (blockType bs) ++ ">" 305 306defaultBlockSpecs :: (Monad m, IsBlock il bl) => [BlockSpec m il bl] 307defaultBlockSpecs = 308 [ indentedCodeSpec 309 , fencedCodeSpec 310 , blockQuoteSpec 311 , atxHeadingSpec 312 , setextHeadingSpec 313 , thematicBreakSpec 314 , listItemSpec (bulletListMarker <|> orderedListMarker) 315 , rawHtmlSpec 316 , attributeSpec 317 ] 318 319defaultFinalizer :: Monad m 320 => BlockNode m il bl 321 -> BlockNode m il bl 322 -> BlockParser m il bl (BlockNode m il bl) 323defaultFinalizer !child !parent = do 324 -- ensure that 'counters' carries information about all 325 -- the block identifiers used, so that auto_identifiers works properly. 326 case lookup "id" (blockAttributes (rootLabel child)) of 327 Nothing -> return () 328 Just !ident -> updateState $ \st -> 329 st{ counters = M.insert ("identifier:" <> ident) 330 (toDyn (0 :: Int)) (counters st) } 331 return $! parent{ subForest = child : subForest parent } 332 333data BlockData m il bl = BlockData 334 { blockSpec :: BlockSpec m il bl 335 , blockLines :: [[Tok]] -- in reverse order 336 , blockStartPos :: [SourcePos] -- in reverse order 337 , blockData :: !Dynamic 338 , blockBlanks :: [Int] -- non-content blank lines in block 339 , blockAttributes :: !Attributes 340 } 341 deriving Show 342 343defBlockData :: BlockSpec m il bl -> BlockData m il bl 344defBlockData spec = BlockData 345 { blockSpec = spec 346 , blockLines = [] 347 , blockStartPos = [] 348 , blockData = toDyn () 349 , blockBlanks = [] 350 , blockAttributes = mempty 351 } 352 353type BlockNode m il bl = Tree (BlockData m il bl) 354 355data BPState m il bl = BPState 356 { referenceMap :: !ReferenceMap 357 , inlineParser :: ReferenceMap -> [Tok] -> m (Either ParseError il) 358 , nodeStack :: [BlockNode m il bl] -- reverse order, head is tip 359 , blockMatched :: !Bool 360 , maybeLazy :: !Bool 361 , maybeBlank :: !Bool 362 , counters :: M.Map Text Dynamic 363 , failurePositions :: M.Map Text SourcePos -- record known positions 364 -- where parsers fail to avoid repetition 365 , attributeParsers :: [ParsecT [Tok] (BPState m il bl) m Attributes] 366 , nextAttributes :: !Attributes 367 } 368 369type BlockParser m il bl = ParsecT [Tok] (BPState m il bl) m 370 371data ListData = ListData 372 { listType :: !ListType 373 , listSpacing :: !ListSpacing 374 } deriving (Show, Eq) 375 376data ListItemData = ListItemData 377 { listItemType :: !ListType 378 , listItemIndent :: !Int 379 , listItemBlanksInside :: !Bool 380 , listItemBlanksAtEnd :: !Bool 381 } deriving (Show, Eq) 382 383runInlineParser :: Monad m 384 => [Tok] 385 -> BlockParser m il bl il 386runInlineParser toks = {-# SCC runInlineParser #-} do 387 refmap <- referenceMap <$> getState 388 ilParser <- inlineParser <$> getState 389 res <- lift $ ilParser refmap toks 390 case res of 391 Right ils -> return $! ils 392 Left err -> mkPT (\_ -> return (Empty (return (Error err)))) 393 -- pass up ParseError 394 395addRange :: (Monad m, IsBlock il bl) 396 => BlockNode m il bl -> bl -> bl 397addRange (Node b _) 398 = ranged (SourceRange 399 (go . reverse $ map (\pos -> 400 (pos, setSourceColumn 401 (incSourceLine pos 1) 1)) 402 (blockStartPos b))) 403 where 404 go [] = [] 405 go ((!startpos1, !endpos1):(!startpos2, !endpos2):rest) 406 | endpos1 == startpos2 = go ((startpos1, endpos2):rest) 407 go (!x:xs) = x : go xs 408 409-- Add a new node to the block stack. If current tip can contain 410-- it, add it there; otherwise, close the tip and repeat til we get 411-- to a block that can contain this node. 412addNodeToStack :: Monad m => BlockNode m bl il -> BlockParser m bl il () 413addNodeToStack node = do 414 (cur:rest) <- nodeStack <$> getState 415 guard $ blockParagraph (bspec cur) || not (blockContainsLines (bspec cur)) 416 if blockCanContain (bspec cur) (bspec node) 417 then do 418 nextAttr <- nextAttributes <$> getState 419 let node' = if null nextAttr 420 then node 421 else 422 let rl = rootLabel node 423 in node{ rootLabel = rl{ 424 blockAttributes = nextAttr 425 }} 426 updateState $ \st -> 427 st{ nextAttributes = mempty 428 , nodeStack = node' : cur : rest 429 , maybeLazy = False } 430 else case rest of 431 (x:xs) -> do 432 stack <- (:xs) <$> collapseNodeStack [cur,x] 433 updateState $ \st -> st{ nodeStack = stack } 434 addNodeToStack node 435 _ -> mzero 436 437interruptsParagraph :: Monad m => BlockParser m bl il Bool 438interruptsParagraph = do 439 (cur:_) <- nodeStack <$> getState 440 return $! blockParagraph (bspec cur) 441 442renderChildren :: (Monad m, IsBlock il bl) 443 => BlockNode m il bl -> BlockParser m il bl [bl] 444renderChildren node = mapM renderC $ subForest node 445 where 446 renderC n = do 447 let attrs = blockAttributes (rootLabel n) 448 (if null attrs 449 then id 450 else addAttributes attrs) . 451 addRange n <$> blockConstructor (blockSpec (rootLabel n)) n 452 453docSpec :: (Monad m, IsBlock il bl, Monoid bl) => BlockSpec m il bl 454docSpec = BlockSpec 455 { blockType = "Doc" 456 , blockStart = mzero 457 , blockCanContain = const True 458 , blockContainsLines = False 459 , blockParagraph = False 460 , blockContinue = \n -> (,n) <$> getPosition 461 , blockConstructor = fmap mconcat . renderChildren 462 , blockFinalize = defaultFinalizer 463 } 464 465refLinkDefSpec :: (Monad m, IsBlock il bl) 466 => BlockSpec m il bl 467refLinkDefSpec = BlockSpec 468 { blockType = "ReferenceLinkDefinition" 469 , blockStart = mzero 470 , blockCanContain = const False 471 , blockContainsLines = False 472 , blockParagraph = False 473 , blockContinue = const mzero 474 , blockConstructor = \node -> do 475 let linkdefs = fromDyn (blockData (rootLabel node)) 476 undefined :: [((SourceRange, Text), LinkInfo)] 477 return $! mconcat $ map (\((range, lab), linkinfo) -> 478 (ranged range 479 (addAttributes (linkAttributes linkinfo) 480 (referenceLinkDefinition lab (linkDestination linkinfo, 481 linkTitle linkinfo))))) linkdefs 482 , blockFinalize = defaultFinalizer 483 } 484 485-- Parse reference links from beginning of block text; 486-- update reference map and block text; return maybe altered node 487-- (if it still contains lines) and maybe ref link node. 488extractReferenceLinks :: (Monad m, IsBlock il bl) 489 => BlockNode m il bl 490 -> BlockParser m il bl (Maybe (BlockNode m il bl), 491 Maybe (BlockNode m il bl)) 492extractReferenceLinks node = do 493 st <- getState 494 res <- lift $ runParserT ((,) <$> ((lookAhead anyTok >>= setPosition . tokPos) >> 495 many1 (linkReferenceDef (choice $ attributeParsers st))) 496 <*> getInput) st "" (getBlockText node) 497 case res of 498 Left _ -> return $! (Just node, Nothing) 499 Right (linkdefs, toks') -> do 500 mapM_ 501 (\((_,lab),linkinfo) -> 502 updateState $ \s -> s{ 503 referenceMap = insertReference lab linkinfo 504 (referenceMap s) }) linkdefs 505 let isRefPos = case toks' of 506 (t:_) -> (< tokPos t) 507 _ -> const False 508 let node' = if null toks' 509 then Nothing 510 else Just node{ rootLabel = 511 (rootLabel node){ 512 blockLines = [toks'], 513 blockStartPos = dropWhile isRefPos 514 (blockStartPos (rootLabel node)) 515 } 516 } 517 let refnode = node{ rootLabel = 518 (rootLabel node){ 519 blockLines = takeWhile (any (isRefPos . tokPos)) 520 (blockLines (rootLabel node)) 521 , blockStartPos = takeWhile isRefPos 522 (blockStartPos (rootLabel node)) 523 , blockData = toDyn linkdefs 524 , blockSpec = refLinkDefSpec 525 }} 526 return $! (node', Just refnode) 527 528attributeSpec :: (Monad m, IsBlock il bl) 529 => BlockSpec m il bl 530attributeSpec = BlockSpec 531 { blockType = "Attribute" 532 , blockStart = do 533 attrParsers <- attributeParsers <$> getState 534 guard $ not (null attrParsers) 535 interruptsParagraph >>= guard . not 536 nonindentSpaces 537 pos <- getPosition 538 attrs <- choice attrParsers 539 skipWhile (hasType Spaces) 540 lookAhead (void lineEnd <|> eof) 541 addNodeToStack $ 542 Node (defBlockData attributeSpec){ 543 blockData = toDyn attrs, 544 blockStartPos = [pos] } [] 545 return BlockStartMatch 546 , blockCanContain = const False 547 , blockContainsLines = False 548 , blockParagraph = False 549 , blockContinue = \n -> do 550 attrParsers <- attributeParsers <$> getState 551 guard $ not (null attrParsers) 552 nonindentSpaces 553 pos <- getPosition 554 attrs <- choice attrParsers 555 skipWhile (hasType Spaces) 556 lookAhead (void lineEnd <|> eof) 557 let oldattrs = fromDyn (blockData (rootLabel n)) mempty :: Attributes 558 let attrs' = oldattrs <> attrs 559 return $! (pos, n{ rootLabel = (rootLabel n){ 560 blockData = toDyn attrs' }}) 561 , blockConstructor = \_ -> return $! mempty 562 , blockFinalize = \node parent -> do 563 let attrs = fromDyn (blockData (rootLabel node)) mempty :: Attributes 564 updateState $ \st -> st{ nextAttributes = attrs } 565 defaultFinalizer node parent 566 } 567 568paraSpec :: (Monad m, IsBlock il bl) 569 => BlockSpec m il bl 570paraSpec = BlockSpec 571 { blockType = "Paragraph" 572 , blockStart = do 573 interruptsParagraph >>= guard . not 574 skipWhile (hasType Spaces) 575 pos <- getPosition 576 notFollowedBy lineEnd 577 addNodeToStack $ 578 Node (defBlockData paraSpec){ 579 blockStartPos = [pos] } [] 580 return BlockStartMatch 581 , blockCanContain = const False 582 , blockContainsLines = True 583 , blockParagraph = True 584 , blockContinue = \n -> lookAhead $ try $ do 585 skipWhile (hasType Spaces) 586 pos <- getPosition 587 notFollowedBy lineEnd 588 return $! (pos, n) 589 , blockConstructor = \node -> 590 paragraph <$> runInlineParser (getBlockText node) 591 , blockFinalize = \child parent -> do 592 (mbchild, mbrefdefs) <- extractReferenceLinks child 593 case (mbchild, mbrefdefs) of 594 (_, Nothing) -> defaultFinalizer child parent 595 (Nothing, Just refnode) 596 -> return $! parent{ subForest = 597 refnode : subForest parent } 598 (Just child', Just refnode) 599 -> return $! parent{ subForest = 600 child' : refnode : subForest parent } 601 } 602 603plainSpec :: (Monad m, IsBlock il bl) 604 => BlockSpec m il bl 605plainSpec = paraSpec{ 606 blockConstructor = \node -> 607 plain <$> runInlineParser (getBlockText node) 608 } 609 610 611linkReferenceDef :: Monad m 612 => ParsecT [Tok] s m Attributes 613 -> ParsecT [Tok] s m ((SourceRange, Text), LinkInfo) 614linkReferenceDef attrParser = try $ do 615 startpos <- getPosition 616 lab <- pLinkLabel 617 guard $ not $ T.all isSpace lab 618 symbol ':' 619 optional whitespace 620 dest <- pLinkDestination 621 (title, attrs) <- option (mempty, mempty) $ try $ do 622 tit <- option mempty $ try (whitespace *> pLinkTitle) 623 skipWhile (hasType Spaces) 624 as <- option mempty attrParser 625 skipWhile (hasType Spaces) 626 lookAhead (void lineEnd <|> eof) 627 return $! (tit, as) 628 endpos <- getPosition 629 void lineEnd <|> eof 630 return $! ((SourceRange [(startpos, endpos)], lab), 631 LinkInfo{ linkDestination = unEntity dest 632 , linkTitle = unEntity title 633 , linkAttributes = attrs }) 634 635atxHeadingSpec :: (Monad m, IsBlock il bl) 636 => BlockSpec m il bl 637atxHeadingSpec = BlockSpec 638 { blockType = "ATXHeading" 639 , blockStart = do 640 nonindentSpaces 641 pos <- getPosition 642 hashes <- many1 (symbol '#') 643 let level = length hashes 644 guard $ level <= 6 645 (spaceTok *> skipMany spaceTok) 646 <|> void (lookAhead lineEnd) 647 <|> lookAhead eof 648 raw <- many (satisfyTok (not . hasType LineEnd)) 649 -- trim off closing ### 650 let removeClosingHash (_ :: Int) [] = [] 651 removeClosingHash 0 (Tok Spaces _ _ : xs) = 652 removeClosingHash 0 xs 653 removeClosingHash _ (Tok (Symbol '#') _ _ : 654 Tok (Symbol '\\') _ _ : _) = 655 reverse raw 656 removeClosingHash _ (Tok (Symbol '#') _ _ : xs) = 657 removeClosingHash 1 xs 658 removeClosingHash 1 (Tok Spaces _ _ : xs) = xs 659 removeClosingHash 1 (x:_) 660 | tokType x /= Symbol '#' = reverse raw 661 removeClosingHash _ xs = xs 662 let raw' = reverse . removeClosingHash 0 . reverse $ raw 663 addNodeToStack $ Node (defBlockData atxHeadingSpec){ 664 blockLines = [raw'], 665 blockData = toDyn level, 666 blockStartPos = [pos] } [] 667 return BlockStartMatch 668 , blockCanContain = const False 669 , blockContainsLines = False 670 , blockParagraph = False 671 , blockContinue = const mzero 672 , blockConstructor = \node -> do 673 let level = fromDyn (blockData (rootLabel node)) 1 674 ils <- runInlineParser (getBlockText node) 675 return $! heading level ils 676 , blockFinalize = \node@(Node cdata children) parent -> do 677 let oldAttr = blockAttributes cdata 678 let toks = getBlockText node 679 (newtoks, attr) <- parseFinalAttributes True toks 680 <|> (return $! (toks, mempty)) 681 defaultFinalizer (Node cdata{ blockAttributes = oldAttr <> attr 682 , blockLines = [newtoks] } 683 children) parent 684 } 685 686setextHeadingSpec :: (Monad m, IsBlock il bl) 687 => BlockSpec m il bl 688setextHeadingSpec = BlockSpec 689 { blockType = "SetextHeading" 690 , blockStart = do 691 (cur:rest) <- nodeStack <$> getState 692 guard $ blockParagraph (bspec cur) 693 nonindentSpaces 694 pos <- getPosition 695 level <- (2 :: Int) <$ skipMany1 (symbol '-') 696 <|> (1 :: Int) <$ skipMany1 (symbol '=') 697 skipWhile (hasType Spaces) 698 lookAhead (eof <|> void lineEnd) 699 -- process any reference links, make sure there's some 700 -- content left 701 (mbcur, mbrefdefs) <- extractReferenceLinks cur 702 updateState $ \st -> 703 st{ nodeStack = case mbrefdefs of 704 Nothing -> rest 705 Just rd -> case rest of 706 (x:xs) -> 707 x{ subForest = 708 rd : subForest x }:xs 709 [] -> [rd] } 710 case mbcur of 711 Nothing -> mzero -- should not happen 712 Just cur' -> do 713 -- replace cur with new setext heading node 714 addNodeToStack $ 715 Node (rootLabel cur'){ 716 blockSpec = setextHeadingSpec, 717 blockData = toDyn level, 718 blockStartPos = 719 blockStartPos (rootLabel cur') ++ [pos] } 720 [] 721 return BlockStartMatch 722 , blockCanContain = const False 723 , blockContainsLines = True 724 , blockParagraph = False 725 , blockContinue = const mzero 726 , blockConstructor = \node -> do 727 let level = fromDyn (blockData (rootLabel node)) 1 728 ils <- runInlineParser (getBlockText node) 729 return $! heading level ils 730 , blockFinalize = \node@(Node cdata children) parent -> do 731 let oldAttr = blockAttributes cdata 732 let toks = getBlockText node 733 (newtoks, attr) <- parseFinalAttributes True toks 734 <|> (return $! (toks, mempty)) 735 defaultFinalizer (Node cdata{ blockAttributes = oldAttr <> attr 736 , blockLines = [newtoks] } 737 children) parent 738 } 739 740parseFinalAttributes :: Monad m 741 => Bool -> [Tok] -> BlockParser m il bl ([Tok], Attributes) 742parseFinalAttributes requireWhitespace ts = do 743 attrParsers <- attributeParsers <$> getState 744 let pAttr' = try $ (if requireWhitespace 745 then () <$ whitespace 746 else optional whitespace) 747 *> choice attrParsers <* optional whitespace <* eof 748 st <- getState 749 res <- lift $ runParserT 750 ((,) <$> many (notFollowedBy pAttr' >> anyTok) 751 <*> option [] pAttr') st "heading contents" ts 752 case res of 753 Left _ -> mzero 754 Right (xs, ys) -> return $! (xs, ys) 755 756blockQuoteSpec :: (Monad m, IsBlock il bl) => BlockSpec m il bl 757blockQuoteSpec = BlockSpec 758 { blockType = "BlockQuote" 759 , blockStart = do 760 nonindentSpaces 761 pos <- getPosition 762 _ <- symbol '>' 763 _ <- option 0 (gobbleSpaces 1) 764 addNodeToStack $ 765 Node (defBlockData blockQuoteSpec){ 766 blockStartPos = [pos] } [] 767 return BlockStartMatch 768 , blockCanContain = const True 769 , blockContainsLines = False 770 , blockParagraph = False 771 , blockContinue = \n -> try $ do 772 nonindentSpaces 773 pos <- getPosition 774 _ <- symbol '>' 775 _ <- gobbleUpToSpaces 1 776 return $! (pos, n) 777 , blockConstructor = \node -> 778 (blockQuote . mconcat) <$> renderChildren node 779 , blockFinalize = defaultFinalizer 780 } 781 782listItemSpec :: (Monad m, IsBlock il bl) 783 => BlockParser m il bl ListType 784 -> BlockSpec m il bl 785listItemSpec parseListMarker = BlockSpec 786 { blockType = "ListItem" 787 , blockStart = do 788 (pos, lidata) <- itemStart parseListMarker 789 let linode = Node (defBlockData $ listItemSpec parseListMarker){ 790 blockData = toDyn lidata, 791 blockStartPos = [pos] } [] 792 let listdata = ListData{ 793 listType = listItemType lidata 794 , listSpacing = TightList } 795 -- spacing gets set in finalize 796 let listnode = Node (defBlockData listSpec){ 797 blockData = toDyn listdata, 798 blockStartPos = [pos] } [] 799 -- list can only interrupt paragraph if bullet 800 -- list or ordered list w/ startnum == 1, 801 -- and not followed by blank 802 (cur:_) <- nodeStack <$> getState 803 when (blockParagraph (bspec cur)) $ do 804 guard $ case listType listdata of 805 BulletList _ -> True 806 OrderedList 1 Decimal _ -> True 807 _ -> False 808 notFollowedBy blankLine 809 let curdata = fromDyn (blockData (rootLabel cur)) 810 (ListData (BulletList '*') TightList) 811 let matchesList (BulletList c) (BulletList d) = c == d 812 matchesList (OrderedList _ e1 d1) 813 (OrderedList _ e2 d2) = e1 == e2 && d1 == d2 814 matchesList _ _ = False 815 case blockType (bspec cur) of 816 "List" | listType curdata `matchesList` 817 listItemType lidata 818 -> addNodeToStack linode 819 _ -> addNodeToStack listnode >> addNodeToStack linode 820 return BlockStartMatch 821 , blockCanContain = const True 822 , blockContainsLines = False 823 , blockParagraph = False 824 , blockContinue = \node@(Node ndata children) -> do 825 let lidata = fromDyn (blockData ndata) 826 (ListItemData (BulletList '*') 0 False False) 827 -- a marker followed by two blanks is just an empty item: 828 guard $ null (blockBlanks ndata) || 829 not (null children) 830 pos <- getPosition 831 gobbleSpaces (listItemIndent lidata) <|> 0 <$ lookAhead blankLine 832 return $! (pos, node) 833 , blockConstructor = fmap mconcat . renderChildren 834 , blockFinalize = \(Node cdata children) parent -> do 835 let lidata = fromDyn (blockData cdata) 836 (ListItemData (BulletList '*') 837 0 False False) 838 let allblanks = concat $ blockBlanks cdata : 839 map (blockBlanks . rootLabel) 840 (filter ((== "List") . blockType . 841 blockSpec . rootLabel) children) 842 curline <- sourceLine <$> getPosition 843 let blanksAtEnd = case allblanks of 844 (l:_) -> l >= curline - 1 845 _ -> False 846 let blanksInside = case length (removeConsecutive allblanks) of 847 n | n > 1 -> True 848 | n == 1 -> not blanksAtEnd 849 | otherwise -> False 850 let lidata' = toDyn $ lidata{ listItemBlanksInside = blanksInside 851 , listItemBlanksAtEnd = blanksAtEnd } 852 defaultFinalizer (Node cdata{ blockData = lidata' } children) 853 parent 854 } 855 856itemStart :: Monad m 857 => BlockParser m il bl ListType 858 -> BlockParser m il bl (SourcePos, ListItemData) 859itemStart parseListMarker = do 860 beforecol <- sourceColumn <$> getPosition 861 gobbleUpToSpaces 3 862 pos <- getPosition 863 ty <- parseListMarker 864 aftercol <- sourceColumn <$> getPosition 865 lookAhead whitespace 866 numspaces <- try (gobbleUpToSpaces 4 <* notFollowedBy whitespace) 867 <|> gobbleSpaces 1 868 <|> 1 <$ lookAhead lineEnd 869 return $! (pos, ListItemData{ 870 listItemType = ty 871 , listItemIndent = (aftercol - beforecol) + numspaces 872 , listItemBlanksInside = False 873 , listItemBlanksAtEnd = False 874 }) 875 876bulletListMarker :: Monad m => BlockParser m il bl ListType 877bulletListMarker = do 878 Tok (Symbol c) _ _ <- symbol '-' <|> symbol '*' <|> symbol '+' 879 return $! BulletList c 880 881orderedListMarker :: Monad m => BlockParser m il bl ListType 882orderedListMarker = do 883 Tok WordChars _ ds <- satisfyWord (\t -> T.all isDigit t && T.length t < 10) 884 (start :: Int) <- either fail (return . fst) (TR.decimal ds) 885 delimtype <- Period <$ symbol '.' <|> OneParen <$ symbol ')' 886 return $! OrderedList start Decimal delimtype 887 888listSpec :: (Monad m, IsBlock il bl) => BlockSpec m il bl 889listSpec = BlockSpec 890 { blockType = "List" 891 , blockStart = mzero 892 , blockCanContain = \sp -> blockType sp == "ListItem" 893 , blockContainsLines = False 894 , blockParagraph = False 895 , blockContinue = \n -> (,n) <$> getPosition 896 , blockConstructor = \node -> do 897 let ListData lt ls = fromDyn (blockData (rootLabel node)) 898 (ListData (BulletList '*') TightList) 899 list lt ls <$> renderChildren node 900 , blockFinalize = \(Node cdata children) parent -> do 901 let ListData lt _ = fromDyn (blockData cdata) 902 (ListData (BulletList '*') TightList) 903 let getListItemData (Node d _) = 904 fromDyn (blockData d) 905 (ListItemData (BulletList '*') 0 False False) 906 let childrenData = map getListItemData children 907 let ls = case childrenData of 908 c:cs | any listItemBlanksInside (c:cs) || 909 (not (null cs) && 910 any listItemBlanksAtEnd cs) 911 -> LooseList 912 _ -> TightList 913 blockBlanks' <- case childrenData of 914 c:_ | listItemBlanksAtEnd c -> do 915 curline <- sourceLine <$> getPosition 916 return $! curline - 1 : blockBlanks cdata 917 _ -> return $! blockBlanks cdata 918 let ldata' = toDyn (ListData lt ls) 919 -- need to transform paragraphs on tight lists 920 let totight (Node nd cs) 921 | blockType (blockSpec nd) == "Paragraph" 922 = Node nd{ blockSpec = plainSpec } cs 923 | otherwise = Node nd cs 924 let childrenToTight (Node nd cs) = Node nd (map totight cs) 925 let children' = 926 if ls == TightList 927 then map childrenToTight children 928 else children 929 defaultFinalizer (Node cdata{ blockData = ldata' 930 , blockBlanks = blockBlanks' } children') 931 parent 932 } 933 934thematicBreakSpec :: (Monad m, IsBlock il bl) 935 => BlockSpec m il bl 936thematicBreakSpec = BlockSpec 937 { blockType = "ThematicBreak" 938 , blockStart = do 939 nonindentSpaces 940 pos <- getPosition 941 Tok (Symbol c) _ _ <- symbol '-' 942 <|> symbol '_' 943 <|> symbol '*' 944 skipWhile (hasType Spaces) 945 let tbchar = symbol c <* skipWhile (hasType Spaces) 946 count 2 tbchar 947 skipMany tbchar 948 (do lookAhead lineEnd 949 addNodeToStack (Node (defBlockData thematicBreakSpec){ 950 blockStartPos = [pos] } []) 951 return BlockStartMatch) <|> 952 (BlockStartNoMatchBefore <$> getPosition) 953 , blockCanContain = const False 954 , blockContainsLines = False 955 , blockParagraph = False 956 , blockContinue = const mzero 957 , blockConstructor = \_ -> return thematicBreak 958 , blockFinalize = defaultFinalizer 959 } 960 961indentedCodeSpec :: (Monad m, IsBlock il bl) 962 => BlockSpec m il bl 963indentedCodeSpec = BlockSpec 964 { blockType = "IndentedCode" 965 , blockStart = do 966 interruptsParagraph >>= guard . not 967 getState >>= guard . not . maybeLazy 968 _ <- gobbleSpaces 4 969 pos <- getPosition 970 notFollowedBy blankLine 971 addNodeToStack $ Node (defBlockData indentedCodeSpec){ 972 blockStartPos = [pos] } [] 973 return BlockStartMatch 974 , blockCanContain = const False 975 , blockContainsLines = True 976 , blockParagraph = False 977 , blockContinue = \node -> do 978 void (gobbleSpaces 4) 979 <|> try (skipWhile (hasType Spaces) <* lookAhead lineEnd) 980 pos <- getPosition 981 return $! (pos, node) 982 983 , blockConstructor = \node -> 984 return $! codeBlock mempty (untokenize (getBlockText node)) 985 , blockFinalize = \(Node cdata children) parent -> do 986 -- strip off blank lines at end: 987 let blanks = takeWhile isblankLine $ blockLines cdata 988 let numblanks = length blanks 989 let cdata' = cdata{ blockLines = 990 drop numblanks $ blockLines cdata 991 , blockStartPos = 992 drop numblanks $ blockStartPos cdata 993 } 994 defaultFinalizer (Node cdata' children) parent 995 } 996 997isblankLine :: [Tok] -> Bool 998isblankLine [] = True 999isblankLine [Tok LineEnd _ _] = True 1000isblankLine (Tok Spaces _ _ : xs) = isblankLine xs 1001isblankLine _ = False 1002 1003fencedCodeSpec :: (Monad m, IsBlock il bl) 1004 => BlockSpec m il bl 1005fencedCodeSpec = BlockSpec 1006 { blockType = "FencedCode" 1007 , blockStart = do 1008 prepos <- getPosition 1009 nonindentSpaces 1010 pos <- getPosition 1011 let indentspaces = sourceColumn pos - sourceColumn prepos 1012 (c, ticks) <- (('`',) <$> many1 (symbol '`')) 1013 <|> (('~',) <$> many1 (symbol '~')) 1014 let fencelength = length ticks 1015 guard $ fencelength >= 3 1016 skipWhile (hasType Spaces) 1017 let infoTok = noneOfToks (LineEnd : [Symbol '`' | c == '`']) 1018 info <- T.strip . unEntity <$> many (pEscaped <|> infoTok) 1019 lookAhead $ void lineEnd <|> eof 1020 1021 let infotoks = tokenize "info string" info 1022 (content, attrs) <- parseFinalAttributes False infotoks 1023 <|> (return $! (infotoks, mempty)) 1024 addNodeToStack $ 1025 Node (defBlockData fencedCodeSpec){ 1026 blockData = toDyn 1027 (c, fencelength, indentspaces, 1028 untokenize content, attrs), 1029 blockStartPos = [pos] } [] 1030 return BlockStartMatch 1031 , blockCanContain = const False 1032 , blockContainsLines = True 1033 , blockParagraph = False 1034 , blockContinue = \node -> try (do 1035 let ((c, fencelength, _, _, _) 1036 :: (Char, Int, Int, Text, Attributes)) = fromDyn 1037 (blockData (rootLabel node)) 1038 ('`', 3, 0, mempty, mempty) 1039 nonindentSpaces 1040 pos <- getPosition 1041 ts <- many1 (symbol c) 1042 guard $ length ts >= fencelength 1043 skipWhile (hasType Spaces) 1044 lookAhead $ void lineEnd <|> eof 1045 endOfBlock 1046 return $! (pos, node)) 1047 <|> (do let ((_, _, indentspaces, _, _) 1048 :: (Char, Int, Int, Text, Attributes)) = fromDyn 1049 (blockData (rootLabel node)) 1050 ('`', 3, 0, mempty, mempty) 1051 pos <- getPosition 1052 _ <- gobbleUpToSpaces indentspaces 1053 return $! (pos, node)) 1054 , blockConstructor = \node -> do 1055 let ((_, _, _, info, attrs) :: (Char, Int, Int, Text, Attributes)) = 1056 fromDyn (blockData (rootLabel node)) ('`', 3, 0, mempty, mempty) 1057 let codetext = untokenize $ drop 1 (getBlockText node) 1058 return $! 1059 if null attrs 1060 then codeBlock info codetext 1061 else addAttributes attrs $ codeBlock info codetext 1062 , blockFinalize = defaultFinalizer 1063 } 1064 1065rawHtmlSpec :: (Monad m, IsBlock il bl) 1066 => BlockSpec m il bl 1067rawHtmlSpec = BlockSpec 1068 { blockType = "RawHTML" 1069 , blockStart = do 1070 pos <- getPosition 1071 (rawHtmlType, toks) <- withRaw $ 1072 do nonindentSpaces 1073 symbol '<' 1074 ty <- choice $ map (\n -> n <$ startCond n) [1..7] 1075 -- some blocks can end on same line 1076 finished <- option False $ do 1077 guard (ty /= 6 && ty /= 7) 1078 endCond ty 1079 return True 1080 when (ty == 7) $ do 1081 -- type 7 blocks can't interrupt a paragraph 1082 (n:_) <- nodeStack <$> getState 1083 guard $ not $ blockParagraph (bspec n) 1084 skipWhile (not . hasType LineEnd) 1085 -- we use 0 as a code to indicate that the block is closed 1086 return $! if finished then 0 else ty 1087 addNodeToStack $ Node (defBlockData rawHtmlSpec){ 1088 blockData = toDyn rawHtmlType, 1089 blockLines = [toks], 1090 blockStartPos = [pos] } [] 1091 return BlockStartMatch 1092 , blockCanContain = const False 1093 , blockContainsLines = True 1094 , blockParagraph = False 1095 , blockContinue = \node@(Node ndata children) -> try $ do 1096 pos <- getPosition 1097 case fromDyn (blockData (rootLabel node)) (0 :: Int) of 1098 0 -> mzero -- 0 means that the block start already closed 1099 6 -> (pos, node) <$ notFollowedBy blankLine 1100 7 -> (pos, node) <$ notFollowedBy blankLine 1101 n -> 1102 (do pos' <- getPosition 1103 lookAhead (endCond n) 1104 endOfBlock 1105 toks <- many (satisfyTok (not . hasType LineEnd)) 1106 le <- option [] $ (:[]) <$> lookAhead lineEnd 1107 return $! (pos', Node ndata{ 1108 blockData = toDyn (0 :: Int) 1109 , blockLines = (toks ++ le) : blockLines ndata 1110 } children)) <|> (return $! (pos, node)) 1111 , blockConstructor = \node -> 1112 return $! rawBlock (Format "html") 1113 (untokenize (getBlockText node)) 1114 , blockFinalize = defaultFinalizer 1115 } 1116 1117---------------- for raw html: 1118 1119startCond :: Monad m => Int -> BlockParser m il bl () 1120startCond 1 = void $ try $ do 1121 satisfyWord (isOneOfCI ["script","pre","style"]) 1122 spaceTok 1123 <|> symbol '>' 1124 <|> lookAhead lineEnd 1125startCond 2 = void $ try $ do 1126 symbol '!' 1127 symbol '-' 1128 symbol '-' 1129startCond 3 = void $ symbol '?' 1130startCond 4 = void $ try $ do 1131 symbol '!' 1132 satisfyWord (\t -> case T.uncons t of 1133 Just (c, _) -> isAsciiUpper c 1134 _ -> False) 1135startCond 5 = void $ try $ do 1136 symbol '!' 1137 symbol '[' 1138 satisfyWord (== "CDATA") 1139 symbol '[' 1140startCond 6 = void $ try $ do 1141 optional (symbol '/') 1142 satisfyWord (isOneOfCI ["address", "article", "aside", "base", 1143 "basefont", "blockquote", "body", "caption", "center", "col", 1144 "colgroup", "dd", "details", "dialog", "dir", "div", "dl", 1145 "dt", "fieldset", "figcaption", "figure", "footer", "form", "frame", 1146 "frameset", "h1", "h2", "h3", "h4", "h5", "h6", "head", "header", 1147 "hr", "html", "iframe", "legend", "li", "link", "main", "menu", 1148 "menuitem", "nav", "noframes", "ol", "optgroup", "option", 1149 "p", "param", "section", "source", "summary", "table", "tbody", 1150 "td", "tfoot", "th", "thead", "title", "tr", "track", "ul"]) 1151 spaceTok 1152 <|> lookAhead lineEnd 1153 <|> symbol '>' 1154 <|> (symbol '/' >> symbol '>') 1155startCond 7 = void $ try $ do 1156 toks <- htmlOpenTag <|> htmlClosingTag 1157 guard $ not $ any (hasType LineEnd) toks 1158 skipWhile (hasType Spaces) 1159 lookAhead lineEnd 1160startCond n = fail $ "Unknown HTML block type " ++ show n 1161 1162endCond :: Monad m => Int -> BlockParser m il bl () 1163endCond 1 = try $ do 1164 let closer = try $ do 1165 symbol '<' 1166 symbol '/' 1167 satisfyWord (isOneOfCI ["script","pre","style"]) 1168 symbol '>' 1169 skipManyTill (satisfyTok (not . hasType LineEnd)) closer 1170endCond 2 = try $ do 1171 let closer = try $ symbol '-' >> symbol '-' >> symbol '>' 1172 skipManyTill (satisfyTok (not . hasType LineEnd)) closer 1173endCond 3 = try $ do 1174 let closer = try $ symbol '?' >> symbol '>' 1175 skipManyTill (satisfyTok (not . hasType LineEnd)) closer 1176endCond 4 = try $ 1177 skipManyTill (satisfyTok (not . hasType LineEnd)) (symbol '>') 1178endCond 5 = try $ do 1179 let closer = try $ symbol ']' >> symbol ']' >> symbol '>' 1180 skipManyTill (satisfyTok (not . hasType LineEnd)) closer 1181endCond 6 = void blankLine 1182endCond 7 = void blankLine 1183endCond n = fail $ "Unknown HTML block type " ++ show n 1184 1185-------------------------------- 1186 1187getBlockText :: BlockNode m il bl -> [Tok] 1188getBlockText = 1189 concat . reverse . blockLines . rootLabel 1190 1191removeIndent :: [Tok] -> [Tok] 1192removeIndent = dropWhile (hasType Spaces) 1193 1194removeConsecutive :: [Int] -> [Int] 1195removeConsecutive (x:y:zs) 1196 | x == y + 1 = removeConsecutive (y:zs) 1197removeConsecutive xs = xs 1198 1199------------------------------------------------------------------------- 1200 1201collapseNodeStack :: [BlockNode m il bl] -> BlockParser m il bl (BlockNode m il bl) 1202collapseNodeStack [] = error "Empty node stack!" -- should not happen 1203collapseNodeStack (n:ns) = foldM go n ns 1204 where go child parent 1205 = if blockCanContain (bspec parent) (bspec child) 1206 then blockFinalize (bspec child) child parent 1207 else error $ "collapseNodeStack: " ++ 1208 T.unpack (blockType (bspec parent)) ++ 1209 " cannot contain " ++ T.unpack (blockType (bspec child)) 1210 1211bspec :: BlockNode m il bl -> BlockSpec m il bl 1212bspec = blockSpec . rootLabel 1213 1214endOfBlock :: Monad m => BlockParser m il bl () 1215endOfBlock = updateState $ \st -> st{ blockMatched = False } 1216 1217