1  module PandocWriter (writeAutomerge) where
  2  
  3  import Automerge (BlockMarker (..), BlockSpan (..), BlockType (..), Heading (..), HeadingLevel (..), Link (..), Mark (..), NoteId (..), Span (..), TextSpan (..), toJSONText)
  4  import Control.Monad.State (State, get, modify, runState)
  5  import qualified Data.Text as T
  6  import Text.Pandoc (WriterOptions)
  7  import Text.Pandoc.Class (PandocMonad)
  8  import Text.Pandoc.Definition as Pandoc (Block (..), Inline (..), Pandoc (Pandoc))
  9  
 10  data ContainerBlockType = BulletListItem | OrderedListItem | BlockQuote deriving (Show, Eq)
 11  
 12  data NoteData = NoteData
 13    { noteCounter :: Int,
 14      -- Accumulated note content spans
 15      noteContents :: [Automerge.Span]
 16    }
 17  
 18  type NotesState = State NoteData
 19  
 20  toAutomergeBlockType :: ContainerBlockType -> BlockType
 21  toAutomergeBlockType BulletListItem = Automerge.UnorderedListItemType
 22  toAutomergeBlockType OrderedListItem = Automerge.OrderedListItemType
 23  toAutomergeBlockType PandocWriter.BlockQuote = Automerge.BlockQuoteType
 24  
 25  writeAutomerge :: (PandocMonad m) => WriterOptions -> Pandoc.Pandoc -> m T.Text
 26  writeAutomerge _ (Pandoc.Pandoc _ blocks) = pure $ toJSONText automergeSpans
 27    where
 28      automergeSpans = mainSpans ++ noteContents notesState
 29      (mainSpans, notesState) = runState (blocksToAutomergeSpans [] blocks) initialState
 30      initialState = NoteData 0 []
 31  
 32  blocksToAutomergeSpans :: [Automerge.BlockType] -> [Pandoc.Block] -> NotesState [Automerge.Span]
 33  blocksToAutomergeSpans parentBlockTypes blocks = fmap concat (perBlockSpans blocks)
 34    where
 35      -- Convert each block into a list of spans (per block), inside the State monad.
 36      perBlockSpans :: [Pandoc.Block] -> NotesState [[Automerge.Span]]
 37      perBlockSpans = mapM (blockToAutomergeSpans parentBlockTypes)
 38  
 39  blockToAutomergeSpans :: [Automerge.BlockType] -> Pandoc.Block -> NotesState [Automerge.Span]
 40  blockToAutomergeSpans parentBlockTypes block = case block of
 41    Pandoc.Plain inlines -> inlinesToAutomergeSpans (parentBlockTypes <> [ParagraphType]) inlines
 42    Pandoc.Para inlines -> do
 43      inlineSpans <- inlinesToAutomergeSpans (parentBlockTypes <> [ParagraphType]) inlines
 44      let blockSpan = Automerge.BlockSpan $ AutomergeBlock ParagraphMarker parentBlockTypes False
 45      return (blockSpan : inlineSpans)
 46    Pandoc.Header level _ inlines -> do
 47      inlineSpans <- inlinesToAutomergeSpans (parentBlockTypes <> [HeadingType]) inlines
 48      let blockSpan = Automerge.BlockSpan $ AutomergeBlock (Automerge.HeadingMarker $ Heading $ HeadingLevel level) parentBlockTypes False
 49      return (blockSpan : inlineSpans)
 50    Pandoc.CodeBlock _ text ->
 51      return
 52        [ Automerge.BlockSpan $ AutomergeBlock Automerge.CodeBlockMarker parentBlockTypes False,
 53          Automerge.TextSpan $ AutomergeText text []
 54        ]
 55    Pandoc.BulletList items ->
 56      concat <$> mapM (containerBlockToAutomergeSpans parentBlockTypes BulletListItem) items
 57    Pandoc.OrderedList _ items ->
 58      concat <$> mapM (containerBlockToAutomergeSpans parentBlockTypes OrderedListItem) items
 59    Pandoc.BlockQuote blocks ->
 60      containerBlockToAutomergeSpans parentBlockTypes PandocWriter.BlockQuote blocks
 61    _ -> return [] -- Ignore blocks we don't recognize
 62  
 63  containerBlockToAutomergeSpans :: [Automerge.BlockType] -> ContainerBlockType -> [Pandoc.Block] -> NotesState [Automerge.Span]
 64  containerBlockToAutomergeSpans parents itemType children = do
 65    let containerSpan = containerBlockToSpan parents itemType
 66        childParentTypes = parents <> [toAutomergeBlockType itemType]
 67    childSpans <- fmap concat $ mapM (blockToAutomergeSpans childParentTypes) children
 68    return (containerSpan : childSpans)
 69    where
 70      containerBlockToSpan :: [Automerge.BlockType] -> ContainerBlockType -> Automerge.Span
 71      containerBlockToSpan parentBlockTypes BulletListItem =
 72        Automerge.BlockSpan $ AutomergeBlock Automerge.UnorderedListItemMarker parentBlockTypes False
 73      containerBlockToSpan parentBlockTypes OrderedListItem =
 74        Automerge.BlockSpan $ AutomergeBlock Automerge.OrderedListItemMarker parentBlockTypes False
 75      containerBlockToSpan parentBlockTypes PandocWriter.BlockQuote =
 76        Automerge.BlockSpan $ AutomergeBlock Automerge.BlockQuoteMarker parentBlockTypes False
 77  
 78  inlinesToAutomergeSpans :: [Automerge.BlockType] -> [Pandoc.Inline] -> NotesState [Automerge.Span]
 79  inlinesToAutomergeSpans parents inlines =
 80    -- Use fmap to lift `mergeSameMarkSpans . concat` over the State structure
 81    fmap (mergeSameMarkSpans . concat) (perInlineSpans inlines)
 82    where
 83      -- Convert each inline into a list of spans, inside the State monad.
 84      perInlineSpans :: [Pandoc.Inline] -> NotesState [[Automerge.Span]]
 85      perInlineSpans = mapM (inlineToAutomergeSpans parents)
 86  
 87  inlineToAutomergeSpans :: [Automerge.BlockType] -> Pandoc.Inline -> NotesState [Automerge.Span]
 88  inlineToAutomergeSpans parents inline = case inline of
 89    Pandoc.Note noteBlocks -> do
 90      -- Generate note ID and create note content
 91      notesState <- get
 92      let newNoteId = noteCounter notesState + 1
 93          noteIdText = T.pack $ show newNoteId
 94  
 95      -- Convert note blocks to spans
 96      noteContentChildBlockSpans <- blocksToAutomergeSpans [NoteContentType] noteBlocks
 97      let noteContentSpan = Automerge.BlockSpan $ AutomergeBlock (NoteContentMarker $ Automerge.NoteId noteIdText) [] False
 98          noteContentSpans = noteContentSpan : noteContentChildBlockSpans
 99  
100      -- Update state
101      modify
102        ( \currentNotestState ->
103            -- Getting a new state using the record update syntax.
104            currentNotestState
105              { noteCounter = newNoteId,
106                noteContents = noteContents currentNotestState ++ noteContentSpans
107              }
108        )
109  
110      -- Return embedded note reference span
111      return [Automerge.BlockSpan $ AutomergeBlock (NoteRefMarker $ Automerge.NoteId noteIdText) parents True]
112    Pandoc.Strong inlines -> do
113      wrappedSpans <- inlinesToAutomergeSpans parents inlines
114      return $ addMark Automerge.Strong wrappedSpans
115    Pandoc.Emph inlines -> do
116      wrappedSpans <- inlinesToAutomergeSpans parents inlines
117      return $ addMark Automerge.Emphasis wrappedSpans
118    Pandoc.Link _ inlines (linkUrl, linkTitle) -> do
119      wrappedSpans <- inlinesToAutomergeSpans parents inlines
120      return $ addMark (Automerge.LinkMark $ Automerge.Link {url = linkUrl, title = linkTitle}) wrappedSpans
121    _ -> return $ Automerge.TextSpan <$> inlineToTextSpan inline
122  
123  mergeSameMarkSpans :: [Automerge.Span] -> [Automerge.Span]
124  mergeSameMarkSpans = foldr mergeOrAppendAdjacent []
125    where
126      mergeOrAppendAdjacent :: Automerge.Span -> [Automerge.Span] -> [Automerge.Span]
127      mergeOrAppendAdjacent x [] = [x]
128      -- We only merge if the adjacent spans are **text** spans and they have the same marks.
129      mergeOrAppendAdjacent (TextSpan xTextSpan) (TextSpan firstOrRestTextSpan : rest)
130        | marks xTextSpan == marks firstOrRestTextSpan =
131            TextSpan (xTextSpan <> firstOrRestTextSpan) : rest
132      mergeOrAppendAdjacent x rest = x : rest
133  
134  inlineToTextSpan :: Pandoc.Inline -> [Automerge.TextSpan]
135  inlineToTextSpan inline = case inline of
136    Pandoc.Str str -> [AutomergeText str []]
137    Pandoc.Space -> [AutomergeText (T.pack " ") []]
138    Pandoc.Code _ text -> [AutomergeText text [Automerge.Code]]
139    -- TODO: Handle other inline elements
140    _ -> []
141  
142  addMark :: Automerge.Mark -> [Automerge.Span] -> [Automerge.Span]
143  addMark mark spans = fmap (addMarkToSpan mark) spans
144    where
145      addMarkToSpan :: Automerge.Mark -> Automerge.Span -> Automerge.Span
146      addMarkToSpan m (Automerge.TextSpan textSpan) = Automerge.TextSpan $ AutomergeText T.empty [m] <> textSpan
147      -- Leave non-text spans (like note refs) unchanged
148      addMarkToSpan _ otherSpan = otherSpan