From fcf455f9b1f138cf87c5a387cde1ab76c7e54790 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 20 Nov 2017 13:45:52 -0800 Subject: [PATCH 1/5] Use `choice` for markdown assignment --- src/Language/Markdown/Assignment.hs | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/src/Language/Markdown/Assignment.hs b/src/Language/Markdown/Assignment.hs index 2ca6edae8..23ff69ab7 100644 --- a/src/Language/Markdown/Assignment.hs +++ b/src/Language/Markdown/Assignment.hs @@ -61,7 +61,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 + , section + , table + ] paragraph :: Assignment paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement) @@ -106,7 +115,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) From 631594e01ed6cf1c5c39333f814390ad4a44536d Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 20 Nov 2017 13:47:46 -0800 Subject: [PATCH 2/5] Don't nest markdown sections/headings There's a major performance problem with the `while` approach to detecting hierarchy in markdown headings/sections. This works around by just having headings stay flat (like they are returned from the cmark parser). --- src/Language/Markdown/Assignment.hs | 7 +------ src/Renderer/TOC.hs | 17 +++++++++-------- 2 files changed, 10 insertions(+), 14 deletions(-) diff --git a/src/Language/Markdown/Assignment.hs b/src/Language/Markdown/Assignment.hs index 23ff69ab7..a9cdf4f25 100644 --- a/src/Language/Markdown/Assignment.hs +++ b/src/Language/Markdown/Assignment.hs @@ -84,12 +84,7 @@ 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 +section = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . termOut <$> currentNode <*> children (many inlineElement)) blockQuote :: Assignment blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement) diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 48f9d9569..4f2962d2e 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -90,7 +90,7 @@ data Declaration = MethodDeclaration { declarationIdentifier :: T.Text } | ClassDeclaration { declarationIdentifier :: T.Text } | FunctionDeclaration { declarationIdentifier :: T.Text } - | SectionDeclaration { declarationIdentifier :: T.Text, declarationLevel :: Int } + | HeadingDeclaration { declarationIdentifier :: T.Text, declarationLevel :: Int } | ErrorDeclaration { declarationIdentifier :: T.Text, declarationLanguage :: Maybe Language } deriving (Eq, Generic, Show) @@ -131,11 +131,12 @@ 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))) 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) level + where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (fmap (\ (Term (In ann _), _) -> (byteRange ann)) (toList terms))) + getSource = firstLine . toText . flip Source.slice blobSource firstLine = T.takeWhile (/= '\n') -- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes. @@ -194,7 +195,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 @@ -334,5 +335,5 @@ toCategoryName declaration = case declaration of FunctionDeclaration _ -> "Function" ClassDeclaration _ -> "Class" MethodDeclaration _ -> "Method" - SectionDeclaration _ l -> "Heading " <> T.pack (show l) + HeadingDeclaration _ l -> "Heading " <> T.pack (show l) ErrorDeclaration{} -> "ParseError" From 4aedbf96476059d540b7cd606f87bb17e3083b8a Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 20 Nov 2017 14:20:23 -0800 Subject: [PATCH 3/5] Track contents as children of the heading --- src/Language/Markdown/Assignment.hs | 11 +++++------ src/Language/Markdown/Syntax.hs | 9 +-------- src/Renderer/TOC.hs | 2 +- 3 files changed, 7 insertions(+), 15 deletions(-) diff --git a/src/Language/Markdown/Assignment.hs b/src/Language/Markdown/Assignment.hs index a9cdf4f25..0e255f2b5 100644 --- a/src/Language/Markdown/Assignment.hs +++ b/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 @@ -68,7 +67,7 @@ blockElement = choice , codeBlock , thematicBreak , htmlBlock - , section + , heading , table ] @@ -83,8 +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 <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . termOut <$> currentNode <*> children (many inlineElement)) +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) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index a4cfd1b04..36e980b73 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/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 diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 4f2962d2e..ca685db36 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -133,7 +133,7 @@ class CustomHasDeclaration syntax where -- | 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) + customToDeclaration Blob{..} ann (Markdown.Heading level terms _) = Just $ HeadingDeclaration (headingText terms) level where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (fmap (\ (Term (In ann _), _) -> (byteRange ann)) (toList terms))) getSource = firstLine . toText . flip Source.slice blobSource From 57dd145dc20bd0fabef8a889953ab16adb285f1a Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 20 Nov 2017 14:20:34 -0800 Subject: [PATCH 4/5] Fix tests and demonstrate removes too --- test/TOCSpec.hs | 2 +- test/fixtures/toc/markdown/headings.A.md | 8 ++++++++ test/fixtures/toc/markdown/headings.B.md | 4 ++++ 3 files changed, 13 insertions(+), 1 deletion(-) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index e273d3a62..504904ae5 100644 --- a/test/TOCSpec.hs +++ b/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)) diff --git a/test/fixtures/toc/markdown/headings.A.md b/test/fixtures/toc/markdown/headings.A.md index 449ac1be0..24cc65b1a 100644 --- a/test/fixtures/toc/markdown/headings.A.md +++ b/test/fixtures/toc/markdown/headings.A.md @@ -1,3 +1,11 @@ +# Introduction + +one, two, three + # One Just some text + +## Two + +abc diff --git a/test/fixtures/toc/markdown/headings.B.md b/test/fixtures/toc/markdown/headings.B.md index 2fec8a7c0..a29586d95 100644 --- a/test/fixtures/toc/markdown/headings.B.md +++ b/test/fixtures/toc/markdown/headings.B.md @@ -4,6 +4,10 @@ Just some text ## Two +xyz + +### This heading is new + more text Final From 94690bebafda807c980369ff4cbf141a82e217be Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 20 Nov 2017 15:09:13 -0800 Subject: [PATCH 5/5] Extract function instead of lambda --- src/Renderer/TOC.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index ca685db36..e6ed1945a 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -135,7 +135,8 @@ class CustomHasDeclaration syntax where instance CustomHasDeclaration Markdown.Heading where customToDeclaration Blob{..} ann (Markdown.Heading level terms _) = Just $ HeadingDeclaration (headingText terms) level - where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (fmap (\ (Term (In ann _), _) -> (byteRange ann)) (toList terms))) + 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')