diff --git a/src/Language/Markdown/Assignment.hs b/src/Language/Markdown/Assignment.hs index 2ca6edae8..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 @@ -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) 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 6eaa546f2..3deef2bf5 100644 --- a/src/Renderer/TOC.hs +++ b/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. @@ -201,7 +203,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 @@ -376,5 +378,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" diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 4d5d06a65..41cce59ea 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -173,7 +173,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