{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module CMark.Sections
(
commonmarkToNodesWithSource,
nodesToDocument,
WithSource(..),
getSource,
stripSource,
Section(..),
Document(..),
flattenDocument,
flattenSection,
flattenTree,
flattenForest,
)
where
#if !(MIN_VERSION_base(4,11,0))
import BasePrelude hiding ((<>))
import Data.Semigroup
#else
import BasePrelude
#endif
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 WithSource a = WithSource Text a
deriving (Eq, Show, Functor, Foldable, Traversable, Generic, Data)
getSource :: WithSource a -> Text
getSource (WithSource src _) = src
stripSource :: WithSource a -> a
stripSource (WithSource _ x) = x
instance Semigroup a => Semigroup (WithSource a) where
WithSource s1 v1 <> WithSource s2 v2 =
WithSource (s1 <> s2) (v1 <> v2)
instance (Monoid a, Semigroup a) => Monoid (WithSource a) where
mempty = WithSource "" mempty
mappend = (<>)
data Section a b = Section {
level :: Int,
heading :: WithSource [Node],
headingAnn :: a,
content :: WithSource [Node],
contentAnn :: b
}
deriving (Eq, Show, Generic, Data)
data Document a b = Document {
preface :: WithSource [Node],
prefaceAnn :: b,
sections :: Tree.Forest (Section a b) }
deriving (Eq, Show, Generic, Data)
commonmarkToNodesWithSource :: [CMarkOption] -> Text -> WithSource [Node]
commonmarkToNodesWithSource opts src = WithSource src ns
where
Node _ DOCUMENT ns = commonmarkToNode opts src
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 :: WithSource [Node] -> Document () ()
nodesToDocument (WithSource src nodes) = do
let prefaceNodes :: [Node]
restNodes :: [(Node, [Node])]
(prefaceNodes, restNodes) = breakAtHeadings nodes
let prefaceAnnotated :: WithSource [Node]
prefaceAnnotated = case restNodes of
[] -> WithSource src prefaceNodes
(x:_) -> WithSource (cutTo (fst x) src) prefaceNodes
let blocks :: [((Int, WithSource [Node]), WithSource [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, WithSource hSrc hNodes),
WithSource afterBlocksSrc afterBlocks)
let makeTree [] = []
makeTree (((level, heading), content) : xs) =
let (nested, others) = span (\x -> x^._1._1 > level) xs
section = Section {
level = level,
heading = heading,
headingAnn = (),
content = content,
contentAnn = ()
}
in Tree.Node section (makeTree nested) : makeTree others
Document {
preface = prefaceAnnotated,
prefaceAnn = (),
sections = makeTree blocks
}
flattenDocument :: Document a b -> WithSource [Node]
flattenDocument Document{..} = preface <> flattenForest sections
flattenSection :: Section a b -> WithSource [Node]
flattenSection Section{..} =
WithSource (getSource heading <> getSource content)
(headingNode : stripSource content)
where
headingNode = Node Nothing (HEADING level) (stripSource heading)
flattenTree :: Tree.Tree (Section a b) -> WithSource [Node]
flattenTree (Tree.Node r f) = flattenSection r <> flattenForest f
flattenForest :: Tree.Forest (Section a b) -> WithSource [Node]
flattenForest = mconcat . map flattenSection . concatMap Tree.flatten
#if __GLASGOW_HASKELL__ == 708
deriving instance Typeable WithSource
deriving instance Typeable Section
deriving instance Typeable Document
#endif