module CMark.Sections
(
commonmarkToAnnotatedNodes,
nodesToDocument,
Annotated(..),
Section(..),
Document(..),
flattenDocument,
flattenSection,
flattenTree,
flattenForest,
)
where
import BasePrelude
import Lens.Micro hiding ((&))
import qualified Data.Text as T
import Data.Text (Text)
import CMark
import qualified Data.Tree as Tree
import Data.List.Split
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)
data Section a b = Section {
level :: Int,
heading :: Annotated [Node],
headingAnn :: a,
content :: Annotated [Node],
contentAnn :: b }
deriving (Eq, Show)
data Document a b = Document {
preface :: Annotated [Node],
prefaceAnn :: b,
sections :: Tree.Forest (Section a b) }
deriving (Eq, Show)
commonmarkToAnnotatedNodes :: [CMarkOption] -> Text -> Annotated [Node]
commonmarkToAnnotatedNodes opts s = Ann s ns
where
Node _ DOCUMENT ns = commonmarkToNode opts s
breakAtHeadings
:: [Node]
-> ([Node], [(Node, [Node])])
breakAtHeadings nodes =
let (init':rest') = split (keepDelimsL (whenElt isHeading)) nodes
in (init', map (fromJust . uncons) rest')
where
isHeading (Node _ (HEADING _) _) = True
isHeading _ = False
start :: Node -> Int
start (Node (Just p) _ _) = startLine p
start (Node Nothing _ _) =
error "CMark.Sections.start: node doesn't have a position"
cut
:: Node
-> Node
-> 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
nodesToDocument :: Annotated [Node] -> Document () ()
nodesToDocument (Ann src nodes) = do
let prefaceNodes :: [Node]
restNodes :: [(Node, [Node])]
(prefaceNodes, restNodes) = breakAtHeadings nodes
let prefaceAnnotated :: Annotated [Node]
prefaceAnnotated = case restNodes of
[] -> Ann src prefaceNodes
(x:_) -> Ann (cutTo (fst x) src) prefaceNodes
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)
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
Document {
preface = prefaceAnnotated,
prefaceAnn = (),
sections = makeTree blocks }
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