Merge pull request #1442 from github/fix-markdown-timeouts

Fix markdown timeouts

src/Language/Markdown/Assignment.hs

@@ -8,13 +8,13 @@ module Language.Markdown.Assignment
 
 import qualified CMarkGFM
 import Data.ByteString (ByteString)
-import Data.Function (on)
+import Data.Functor (void)
 import Data.Record
 import Data.Syntax (makeTerm)
 import qualified Data.Syntax as Syntax
 import Data.Syntax.Assignment hiding (Assignment, Error)
 import qualified Data.Syntax.Assignment as Assignment
-import Data.Term as Term (Term(..), TermF(..), termIn, unwrap)
+import Data.Term as Term (Term(..), TermF(..), termIn)
 import qualified Data.Text as Text
 import Data.Text.Encoding (encodeUtf8)
 import Data.Union
@@ -30,7 +30,6 @@ type Syntax =
    , Markup.HTMLBlock
    , Markup.OrderedList
    , Markup.Paragraph
-   , Markup.Section
    , Markup.ThematicBreak
    , Markup.UnorderedList
    , Markup.Table
@@ -61,7 +60,16 @@ assignment = Syntax.handleError $ makeTerm <$> symbol Document <*> children (Mar
 -- Block elements
 
 blockElement :: Assignment
-blockElement = paragraph <|> list <|> blockQuote <|> codeBlock <|> thematicBreak <|> htmlBlock <|> section <|> table
+blockElement = choice
+  [ paragraph
+  , list
+  , blockQuote
+  , codeBlock
+  , thematicBreak
+  , htmlBlock
+  , heading
+  , table
+  ]
 
 paragraph :: Assignment
 paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement)
@@ -74,13 +82,8 @@ list = termIn <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}
 item :: Assignment
 item = makeTerm <$> symbol Item <*> children (many blockElement)
 
-section :: Assignment
-section = makeTerm <$> symbol Heading <*> (heading >>= \ headingTerm -> Markup.Section (level headingTerm) headingTerm <$> while (((<) `on` level) headingTerm) blockElement)
-  where heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . termOut <$> currentNode <*> children (many inlineElement))
-        level term = case term of
-          _ | Just section <- prj (unwrap term) -> level (Markup.sectionHeading section)
-          _ | Just heading <- prj (unwrap term) -> Markup.headingLevel heading
-          _ -> maxBound
+heading :: Assignment
+heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . termOut <$> currentNode <*> children (many inlineElement) <*> manyTill blockElement (void (symbol Heading) <|> eof))
 
 blockQuote :: Assignment
 blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement)
@@ -106,7 +109,18 @@ tableCell = makeTerm <$> symbol TableCell <*> children (Markup.TableCell <$> man
 -- Inline elements
 
 inlineElement :: Assignment
-inlineElement = strong <|> emphasis <|> strikethrough <|> text <|> link <|> htmlInline <|> image <|> code <|> lineBreak <|> softBreak
+inlineElement = choice
+  [ strong
+  , emphasis
+  , strikethrough
+  , text
+  , link
+  , htmlInline
+  , image
+  , code
+  , lineBreak
+  , softBreak
+  ]
 
 strong :: Assignment
 strong = makeTerm <$> symbol Strong <*> children (Markup.Strong <$> many inlineElement)

src/Language/Markdown/Syntax.hs

@@ -28,14 +28,7 @@ instance Eq1 Paragraph where liftEq = genericLiftEq
 instance Ord1 Paragraph where liftCompare = genericLiftCompare
 instance Show1 Paragraph where liftShowsPrec = genericLiftShowsPrec
 
-data Section a = Section { sectionLevel :: Int, sectionHeading :: a, sectionContent :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
-
-instance Eq1 Section where liftEq = genericLiftEq
-instance Ord1 Section where liftCompare = genericLiftCompare
-instance Show1 Section where liftShowsPrec = genericLiftShowsPrec
-
-data Heading a = Heading { headingLevel :: Int, headingContent :: [a] }
+data Heading a = Heading { headingLevel :: Int, headingContent :: [a], sectionContent :: [a] }
   deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Heading where liftEq = genericLiftEq

src/Renderer/TOC.hs

@@ -94,7 +94,7 @@ data Declaration
   = MethodDeclaration   { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationReceiver :: Maybe T.Text }
   | ClassDeclaration    { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language }
   | FunctionDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language }
-  | SectionDeclaration  { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationLevel :: Int }
+  | HeadingDeclaration  { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationLevel :: Int }
   | ErrorDeclaration    { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language }
   deriving (Eq, Generic, Show)
 
@@ -135,11 +135,13 @@ class CustomHasDeclaration syntax where
   customToDeclaration :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> RAlgebra syntax (Term whole (Record fields)) (Maybe Declaration)
 
 
--- | Produce a 'SectionDeclaration' from the first line of the heading of a 'Markdown.Section' node.
-instance CustomHasDeclaration Markdown.Section where
-  customToDeclaration Blob{..} _ (Markdown.Section level (Term (In headingAnn headingF), _) _)
-    = Just $ SectionDeclaration (maybe (getSource (byteRange headingAnn)) (getSource . sconcat) (nonEmpty (byteRange . termAnnotation . unTerm <$> toList headingF))) mempty blobLanguage level
-    where getSource = firstLine . toText . flip Source.slice blobSource
+-- | Produce a 'HeadingDeclaration' from the first line of the heading of a 'Markdown.Heading' node.
+instance CustomHasDeclaration Markdown.Heading where
+  customToDeclaration Blob{..} ann (Markdown.Heading level terms _)
+    = Just $ HeadingDeclaration (headingText terms) mempty blobLanguage level
+    where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
+          headingByteRange (Term (In ann _), _) = byteRange ann
+          getSource = firstLine . toText . flip Source.slice blobSource
           firstLine = T.takeWhile (/= '\n')
 
 -- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes.
@@ -198,7 +200,7 @@ type family DeclarationStrategy syntax where
   DeclarationStrategy Declaration.Class = 'Custom
   DeclarationStrategy Declaration.Function = 'Custom
   DeclarationStrategy Declaration.Method = 'Custom
-  DeclarationStrategy Markdown.Section = 'Custom
+  DeclarationStrategy Markdown.Heading = 'Custom
   DeclarationStrategy Syntax.Error = 'Custom
   DeclarationStrategy (Union fs) = 'Custom
   DeclarationStrategy a = 'Default
@@ -373,5 +375,5 @@ toCategoryName declaration = case declaration of
   ClassDeclaration{} -> "Class"
   FunctionDeclaration{} -> "Function"
   MethodDeclaration{} -> "Method"
-  SectionDeclaration _ _ _ l -> "Heading " <> T.pack (show l)
+  HeadingDeclaration _ _ _ l -> "Heading " <> T.pack (show l)
   ErrorDeclaration{} -> "ParseError"

test/TOCSpec.hs

@@ -174,7 +174,7 @@ spec = parallel $ do
     it "summarizes Markdown headings" $ do
       blobs <- blobsForPaths (both "markdown/headings.A.md" "markdown/headings.B.md")
       output <- runTask (diffBlobPair ToCDiffRenderer blobs)
-      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[1,1],\"end\":[7,10]},\"category\":\"Heading 1\",\"term\":\"One\",\"changeType\":\"modified\"},{\"span\":{\"start\":[5,1],\"end\":[7,10]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"added\"},{\"span\":{\"start\":[9,1],\"end\":[10,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
+      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[1,1],\"end\":[3,16]},\"category\":\"Heading 1\",\"term\":\"Introduction\",\"changeType\":\"removed\"},{\"span\":{\"start\":[5,1],\"end\":[7,4]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"modified\"},{\"span\":{\"start\":[9,1],\"end\":[11,10]},\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"changeType\":\"added\"},{\"span\":{\"start\":[13,1],\"end\":[14,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
 
 
 type Diff' = Diff Syntax (Record (Maybe Declaration ': DefaultFields)) (Record (Maybe Declaration ': DefaultFields))

test/fixtures/toc/markdown/headings.A.md

@@ -1,3 +1,11 @@
+# Introduction
+
+one, two, three
+
 # One
 
 Just some text
+
+## Two
+
+abc

test/fixtures/toc/markdown/headings.B.md

@@ -4,6 +4,10 @@ Just some text
 
 ## Two
 
+xyz
+
+### This heading is new
+
 more text
 
 Final