diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + +First release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Artyom + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Artyom nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cmark-sections.cabal b/cmark-sections.cabal new file mode 100644 --- /dev/null +++ b/cmark-sections.cabal @@ -0,0 +1,51 @@ +name: cmark-sections +version: 0.1.0.0 +synopsis: Represent cmark-parsed Markdown as a tree of sections +description: + Represent cmark-parsed Markdown as a tree of sections +homepage: http://github.com/aelve/cmark-sections +bug-reports: http://github.com/aelve/cmark-sections/issues +license: BSD3 +license-file: LICENSE +author: Artyom +maintainer: yom@artyom.me +-- copyright: +category: Text +tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/aelve/cmark-sections.git + +library + exposed-modules: CMark.Sections + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <5 + , base-prelude == 1.* + , cmark >= 0.5 && < 0.5.4 + , containers + , microlens == 0.4.* + , split == 0.2.* + , text + ghc-options: -Wall -fno-warn-unused-do-bind + hs-source-dirs: lib + default-language: Haskell2010 + +test-suite tests + main-is: Main.hs + type: exitcode-stdio-1.0 + build-depends: QuickCheck >= 2.8 && < 3 + , base >=4.7 && <5 + , base-prelude == 1.* + , cmark + , cmark-sections + , containers + , hspec == 2.2.* + , text + ghc-options: -Wall -fno-warn-unused-do-bind + hs-source-dirs: tests + default-language: Haskell2010 diff --git a/lib/CMark/Sections.hs b/lib/CMark/Sections.hs new file mode 100644 --- /dev/null +++ b/lib/CMark/Sections.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE +TemplateHaskell, +RecordWildCards, +DeriveFunctor, +DeriveFoldable, +DeriveTraversable, +OverloadedStrings, +NoImplicitPrelude + #-} + + +{- | +This library lets you parse Markdown into a hierarchical structure (delimited by headings). For instance, let's say your document looks like this: + +@ +This is the preface. + +First chapter +======================================== + +This chapter doesn't have sections. + +Second chapter +======================================== + +First section +-------------------- + +Here's some text. + +Second section +-------------------- + +And more text. +@ + +It can be represented as a tree: + +@ +'preface': "This is the preface." +'sections': + * 'heading': __"First chapter"__ + 'content': "This chapter doesn't have sections." + 'sections': [] + + * 'heading': __"Second chapter"__ + 'sections': + * 'heading': __"First section"__ + 'content': "Here's some text." + 'sections': [] + + * 'heading': __"Second section"__ + 'content': "And more text." + 'sections': [] +@ + +That's what this library does. Moreover, it lets you access the Markdown source of every node of the tree. + +In most cases the only thing you need to do is something like this: + +@ +'nodesToDocument' . 'commonmarkToAnnotatedNodes' ['optSafe', 'optNormalize'] +@ + +You can preprocess parsed Markdown after doing 'commonmarkToAnnotatedNodes' as long as you don't add or remove any top-level nodes. +-} +module CMark.Sections +( + -- * Parse Markdown to trees + commonmarkToAnnotatedNodes, + nodesToDocument, + Annotated(..), + Section(..), + Document(..), + + -- * Work with parsed trees + -- $monoid-note + flattenDocument, + flattenSection, + flattenTree, + flattenForest, +) +where + + +import BasePrelude +-- Lenses +import Lens.Micro hiding ((&)) +-- Text +import qualified Data.Text as T +import Data.Text (Text) +-- Markdown +import CMark +-- Containers +import qualified Data.Tree as Tree +-- Lists +import Data.List.Split + + +{- | +A data type for annotating things with their source. In this library we only use @Annotated [Node]@, which stands for “some Markdown nodes + source”. +-} +data Annotated a = Ann { + annSource :: Text, + annValue :: a } + deriving (Eq, Show, Functor, Foldable, Traversable) + +instance Monoid a => Monoid (Annotated a) where + mempty = Ann "" mempty + Ann s1 v1 `mappend` Ann s2 v2 = Ann (s1 <> s2) (v1 <> v2) + +{- | +A section in the Markdown tree. Does not contain subsections (the tree is built using 'Tree.Forest' from "Data.Tree"). +-} +data Section a b = Section { + -- | Level (from 1 to 6). + level :: Int, + heading :: Annotated [Node], + headingAnn :: a, + -- | Text between the heading and the first subsection. Can be empty. + content :: Annotated [Node], + contentAnn :: b } + deriving (Eq, Show) + +{- | +The whole parsed Markdown tree. The first parameter is the type of annotations for headings (i.e. sections), the second – chunks of text (which are all associated with sections except for the preface). +-} +data Document a b = Document { + -- | Text before the first section. Can be empty. + preface :: Annotated [Node], + prefaceAnn :: b, + sections :: Tree.Forest (Section a b) } + deriving (Eq, Show) + +{- | +'commonmarkToAnnotatedNodes' parses Markdown with the given options and extracts nodes from the initial 'DOCUMENT' node. +-} +commonmarkToAnnotatedNodes :: [CMarkOption] -> Text -> Annotated [Node] +commonmarkToAnnotatedNodes opts s = Ann s ns + where + Node _ DOCUMENT ns = commonmarkToNode opts s + +{- | Break Markdown into pieces: + +@ + blah blah blah } + }----> init + blah blah blah } + + # foo } + } + blah blah }----> (heading, blocks after) + } + blah blah } + + ## bar } + }----> (heading, blocks after) + blah blah } + + ... +@ +-} +breakAtHeadings + :: [Node] + -> ([Node], [(Node, [Node])]) -- ^ (blocks before the first heading, + -- headings + blocks after) +breakAtHeadings nodes = + let (init':rest') = split (keepDelimsL (whenElt isHeading)) nodes + in (init', map (fromJust . uncons) rest') + where + isHeading (Node _ (HEADING _) _) = True + isHeading _ = False + +-- | Get start line of a node. +start :: Node -> Int +start (Node (Just p) _ _) = startLine p +start (Node Nothing _ _) = + error "CMark.Sections.start: node doesn't have a position" + +-- We assume here that two top-level blocks can't possibly be on the same line. +cut + :: Node -- ^ First node to include + -> Node -- ^ First node to exclude + -> Text + -> Text +cut a b = T.unlines . take (start b - start a) . drop (start a - 1) . T.lines + +cutTo + :: Node + -> Text + -> Text +cutTo b = T.unlines . take (start b - 1) . T.lines + +cutFrom + :: Node + -> Text + -> Text +cutFrom a = T.unlines . drop (start a - 1) . T.lines + +{- | +Turn a list of Markdown nodes into a tree. +-} +nodesToDocument :: Annotated [Node] -> Document () () +nodesToDocument (Ann src nodes) = do + -- Break at headings + let prefaceNodes :: [Node] + restNodes :: [(Node, [Node])] + (prefaceNodes, restNodes) = breakAtHeadings nodes + -- Annotate the first block with the source. If there are no headings at + -- all, we just copy everything; otherwise we cut until the first heading. + let prefaceAnnotated :: Annotated [Node] + prefaceAnnotated = case restNodes of + [] -> Ann src prefaceNodes + (x:_) -> Ann (cutTo (fst x) src) prefaceNodes + -- Annotate other blocks with their sources by cutting until the position + -- of the next block + let blocks :: [((Int, Annotated [Node]), Annotated [Node])] + blocks = do + ((heading, afterBlocks), mbNext) <- + zip restNodes (tail (map Just restNodes ++ [Nothing])) + let Node _ (HEADING hLevel) hNodes = heading + let hSrc = case (afterBlocks, mbNext) of + (x:_, _) -> cut heading x src + ([], Just (x, _)) -> cut heading x src + ([], Nothing) -> cutFrom heading src + let afterBlocksSrc = case (afterBlocks, mbNext) of + ([], _) -> "" + (x:_, Just (y, _)) -> cut x y src + (x:_, Nothing) -> cutFrom x src + return ((hLevel, Ann hSrc hNodes), + Ann afterBlocksSrc afterBlocks) + -- A function for turning blocks into a tree + let makeTree [] = [] + makeTree (((level, heading), content) : xs) = + let (nested, others) = span (\x -> x^._1._1 > level) xs + section = Section { + headingAnn = (), + contentAnn = (), + .. } + in Tree.Node section (makeTree nested) : makeTree others + -- Return the result + Document { + preface = prefaceAnnotated, + prefaceAnn = (), + sections = makeTree blocks } + +{- $monoid-note + +Note that you can use ('<>') to combine 'Annotated' nodes together. +-} + +flattenDocument :: Document a b -> Annotated [Node] +flattenDocument Document{..} = preface <> flattenForest sections + +flattenSection :: Section a b -> Annotated [Node] +flattenSection Section{..} = + Ann (annSource heading <> annSource content) + (headingNode : annValue content) + where + headingNode = Node Nothing (HEADING level) (annValue heading) + +flattenTree :: Tree.Tree (Section a b) -> Annotated [Node] +flattenTree (Tree.Node r f) = flattenSection r <> flattenForest f + +flattenForest :: Tree.Forest (Section a b) -> Annotated [Node] +flattenForest = mconcat . map flattenSection . concatMap Tree.flatten diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE +OverloadedStrings, +RecordWildCards, +ViewPatterns, +NoImplicitPrelude + #-} + + +module Main where + + +import BasePrelude +-- Trees +import qualified Data.Tree as Tree +-- Text +import qualified Data.Text as T +import Data.Text (Text) +-- Tests +import Test.Hspec +import Test.QuickCheck +import Test.Hspec.QuickCheck +-- Markdown +import CMark +import CMark.Sections + + +main :: IO () +main = hspec $ do + let mkSect level heading content ns = + Tree.Node Section{headingAnn = (),contentAnn = (),..} ns + describe "converting:" $ do + it "empty document" $ do + let src = "" + prefaceAnn = () + preface = mempty + sections = [] + nodesToDocument (commonmarkToAnnotatedNodes [] src) + `shouldBe` Document{..} + it "spaces" $ do + let src = " \n\n \n" + prefaceAnn = () + preface = Ann " \n\n \n" [] + sections = [] + nodesToDocument (commonmarkToAnnotatedNodes [] src) + `shouldBe` Document{..} + it "paragraph" $ do + let src = "x" + prefaceAnn = () + preface = Ann "x" [ + Node (Just (PosInfo 1 1 1 1)) PARAGRAPH [text "x"] ] + sections = [] + nodesToDocument (commonmarkToAnnotatedNodes [] src) + `shouldBe` Document{..} + it "3 paragraphs" $ do + let src = T.unlines ["","x","","","y","","z",""] + prefaceAnn = () + preface = Ann "\nx\n\n\ny\n\nz\n\n" [ + Node (Just (PosInfo 2 1 2 1)) PARAGRAPH [text "x"], + Node (Just (PosInfo 5 1 5 1)) PARAGRAPH [text "y"], + Node (Just (PosInfo 7 1 7 1)) PARAGRAPH [text "z"] ] + sections = [] + nodesToDocument (commonmarkToAnnotatedNodes [] src) + `shouldBe` Document{..} + it "headers" $ do + let src = T.unlines ["# 1", "", "## 2", "", "## 3"] + prefaceAnn = () + preface = mempty + sections = [ + mkSect 1 (Ann "# 1\n\n" [text "1"]) mempty [ + mkSect 2 (Ann "## 2\n\n" [text "2"]) mempty [], + mkSect 2 (Ann "## 3\n" [text "3"]) mempty [] ] ] + nodesToDocument (commonmarkToAnnotatedNodes [] src) + `shouldBe` Document{..} + it "headers+content" $ do + let src = T.unlines ["# 1", "", "## 2", "test", "## 3"] + prefaceAnn = () + preface = mempty + sections = [ + mkSect 1 (Ann "# 1\n\n" [text "1"]) mempty [ + mkSect 2 (Ann "## 2\n" [text "2"]) + (Ann "test\n" [Node (Just (PosInfo 4 1 4 4)) PARAGRAPH + [text "test"]]) [], + mkSect 2 (Ann "## 3\n" [text "3"]) mempty [] ] ] + nodesToDocument (commonmarkToAnnotatedNodes [] src) + `shouldBe` Document{..} + it "preface+headers" $ do + let src = T.unlines ["blah", "# 1", "", "## 2", "", "## 3"] + prefaceAnn = () + preface = commonmarkToAnnotatedNodes [] "blah\n" + sections = [ + mkSect 1 (Ann "# 1\n\n" [text "1"]) mempty [ + mkSect 2 (Ann "## 2\n\n" [text "2"]) mempty [], + mkSect 2 (Ann "## 3\n" [text "3"]) mempty [] ] ] + nodesToDocument (commonmarkToAnnotatedNodes [] src) + `shouldBe` Document{..} + + describe "reconstruction:" $ do + it "paragraph + ###-header" $ + fromToDoc "foo\n\n# bar\n" + it "paragraph + ===-header" $ + fromToDoc "foo\n\nbar\n===\n" + it "no blank line after header" $ + fromToDoc "# header\n# header\n" + it "header + blockquote" $ + fromToDoc "# header\n\n> a blockquote\n" + it "header + list" $ + fromToDoc "# header\n * item\n" + it "blanks + header" $ + fromToDoc "\n\n\n# header\n" + modifyMaxSize (*20) $ modifyMaxSuccess (*10) $ + prop "QuickCheck" $ + forAllShrink mdGen shrinkMD $ \(T.concat -> src) -> + let md1 = commonmarkToAnnotatedNodes [] src + md2 = flattenDocument . nodesToDocument $ md1 + err = printf "%s: %s /= %s" (show src) (show md1) (show md2) + in counterexample err (compareMD md1 md2) + +text :: Text -> Node +text t = Node Nothing (TEXT t) [] + +fromToDoc :: Text -> Expectation +fromToDoc src = + flattenDocument (nodesToDocument (commonmarkToAnnotatedNodes [] src)) + `shouldBeMD` commonmarkToAnnotatedNodes [] src + +shouldBeMD :: Annotated [Node] -> Annotated [Node] -> Expectation +shouldBeMD x y = x `shouldSatisfy` (compareMD y) + +-- | Check that pieces of Markdown are equivalent (modulo trailing newline +-- and position info). +compareMD :: Annotated [Node] -> Annotated [Node] -> Bool +compareMD x y = + map (\(Node _ a b) -> Node Nothing a b) (annValue x) == + map (\(Node _ a b) -> Node Nothing a b) (annValue y) + && + or [annSource x == annSource y, + and [not (T.isSuffixOf "\n" (annSource x)), + T.isSuffixOf "\n" (annSource y), + annSource x == T.init (annSource y)], + and [not (T.isSuffixOf "\n" (annSource y)), + T.isSuffixOf "\n" (annSource x), + annSource y == T.init (annSource x)] ] + +-- | Try to shrink Markdown. +shrinkMD :: [Text] -> [[Text]] +shrinkMD = shrinkList shrinkNothing + +-- | Generate random Markdown. +mdGen :: Gen [Text] +mdGen = do + ls <- listOf $ elements [ + -- ###-headers + "# header 1\n", "# header 1 #\n", + "## header 2\n", + "### header 3\n", + "#### header 4\n", + "##### header 5\n", + "###### header 6\n", + " # header 1\n", " # header 1\n", + " ## header 2\n", " ## header 2\n", + -- ===-headers + "header 1\n======\n", "header 2\n------\n", + "multiline\nheader 1\n======\n", "multiline\nheader 2\n------\n", + -- blocks with headers inside + "> # header\n", "* # header\n", + -- lists + "* item\n", " * item\n", + "+ item 1\n+ item 2\n", + -- links and link references + "[link][link]\n", + "[link]: http://google.com\n", + "> [link]: http://google.com\n", + -- blockquotes + "> blockquote\n> 1\n", ">> blockquote\n>> 2\n", + -- other blocks + " a *paragraph*\n", + "*multiline*\nparagraph\n", + "~~~\ncode block\n~~~\n", " code\n", + "---\n", "* * *\n", " * * * \n", + -- other things + "", " ", " ", "\n", "\n\n", + "`", "``", "```"] + let randomNL = T.replicate <$> choose (0, 3) <*> pure "\n" + concat <$> mapM (\x -> do nl <- randomNL; return [x, nl]) ls