1  {-# LANGUAGE InstanceSigs #-}
  2  {-# LANGUAGE OverloadedStrings #-}
  3  
  4  module Automerge (parseAutomergeSpans, parseAutomergeSpansText, Span (..), BlockMarker (..), Heading (..), HeadingLevel (..), NoteId (..), BlockSpan (..), BlockType (..), TextSpan (..), Mark (..), Link (..), toJSONText, takeUntilNonEmbedBlockSpan, takeUntilNextSameBlockTypeSibling, isTopLevelBlock, isParent, isSiblingListItem) where
  5  
  6  import Data.Aeson (FromJSON (parseJSON), Object, ToJSON (toJSON), Value (Bool, Null, String), eitherDecode, eitherDecodeStrictText, encode, object, withObject, withScientific, withText, (.!=), (.:), (.:?), (.=))
  7  import qualified Data.Aeson.Key as K
  8  import qualified Data.Aeson.KeyMap as KM
  9  import Data.Aeson.Types (Parser)
 10  import qualified Data.ByteString.Lazy as BL
 11  import qualified Data.ByteString.Lazy.Char8 as BSL8
 12  import Data.List (unsnoc)
 13  import qualified Data.Text as T
 14  import Data.Text.Encoding (decodeUtf8)
 15  import Utils.JSON (parseNonEmpty, parseStringifiedObject, stringifyObject)
 16  
 17  -- TODO: Make title optional
 18  data Link = Link {url :: T.Text, title :: T.Text} deriving (Show, Eq)
 19  
 20  instance FromJSON Link where
 21    parseJSON = withObject "Link" $ \v -> do
 22      linkUrl <- v .: "href" >>= parseNonEmpty "href"
 23      linkTitle <- v .: "title"
 24      pure Link {url = linkUrl, title = linkTitle}
 25  
 26  instance ToJSON Link where
 27    toJSON link = object ["href" .= url link, "title" .= title link]
 28  
 29  data Mark
 30    = Strong
 31    | Emphasis
 32    | LinkMark Link
 33    | Code
 34    deriving (Show, Eq)
 35  
 36  newtype HeadingLevel = HeadingLevel Int deriving (Show, Eq)
 37  
 38  instance FromJSON HeadingLevel where
 39    parseJSON = withScientific "HeadingLevel" $ \n -> do
 40      let level = floor n
 41      if level >= 1 && level <= 6
 42        then pure $ HeadingLevel level
 43        else fail "Invalid heading level"
 44  
 45  newtype Heading = Heading HeadingLevel deriving (Show, Eq)
 46  
 47  newtype NoteId = NoteId T.Text deriving (Show, Eq)
 48  
 49  instance FromJSON NoteId where
 50    parseJSON = withText "NoteId" $ \t -> do
 51      noteId <- parseNonEmpty "id" t
 52      pure $ NoteId noteId
 53  
 54  data BlockType
 55    = ParagraphType
 56    | HeadingType
 57    | CodeBlockType
 58    | BlockQuoteType
 59    | OrderedListItemType
 60    | UnorderedListItemType
 61    | ImageType
 62    | NoteRefType
 63    | NoteContentType
 64    deriving (Show, Eq)
 65  
 66  instance FromJSON BlockType where
 67    parseJSON :: Value -> Parser BlockType
 68    parseJSON = withText "BlockType" $ \t -> case t of
 69      "paragraph" -> pure ParagraphType
 70      "heading" -> pure HeadingType
 71      "code-block" -> pure CodeBlockType
 72      "blockquote" -> pure BlockQuoteType
 73      "ordered-list-item" -> pure OrderedListItemType
 74      "unordered-list-item" -> pure UnorderedListItemType
 75      "image" -> pure ImageType
 76      "__ext__note_ref" -> pure NoteRefType
 77      "__ext__note_content" -> pure NoteContentType
 78      _ -> fail "Invalid block type"
 79  
 80  instance ToJSON BlockType where
 81    toJSON :: BlockType -> Value
 82    toJSON bt = case bt of
 83      ParagraphType -> String "paragraph"
 84      HeadingType -> String "heading"
 85      CodeBlockType -> String "code-block"
 86      BlockQuoteType -> String "blockquote"
 87      OrderedListItemType -> String "ordered-list-item"
 88      UnorderedListItemType -> String "unordered-list-item"
 89      ImageType -> String "image"
 90      NoteRefType -> String "__ext__note_ref"
 91      NoteContentType -> String "__ext__note_content"
 92  
 93  data BlockMarker
 94    = ParagraphMarker
 95    | HeadingMarker Heading
 96    | CodeBlockMarker
 97    | BlockQuoteMarker
 98    | OrderedListItemMarker
 99    | UnorderedListItemMarker
100    | ImageBlockMarker
101    | NoteRefMarker NoteId
102    | NoteContentMarker NoteId
103    deriving (Show, Eq)
104  
105  data TextSpan = AutomergeText {value :: T.Text, marks :: [Mark]} deriving (Show, Eq)
106  
107  instance Semigroup TextSpan where
108    (<>) (AutomergeText value1 marks1) (AutomergeText value2 marks2) = AutomergeText (value1 <> value2) (marks1 <> marks2)
109  
110  instance Monoid TextSpan where
111    mempty = AutomergeText T.empty []
112  
113  data BlockSpan = AutomergeBlock {blockMarker :: BlockMarker, parentTypes :: [BlockType], isEmbed :: Bool} deriving (Show, Eq)
114  
115  blockType :: BlockSpan -> BlockType
116  blockType (AutomergeBlock (ParagraphMarker) _ _) = ParagraphType
117  blockType (AutomergeBlock (HeadingMarker _) _ _) = HeadingType
118  blockType (AutomergeBlock (CodeBlockMarker) _ _) = CodeBlockType
119  blockType (AutomergeBlock (BlockQuoteMarker) _ _) = BlockQuoteType
120  blockType (AutomergeBlock (OrderedListItemMarker) _ _) = OrderedListItemType
121  blockType (AutomergeBlock (UnorderedListItemMarker) _ _) = UnorderedListItemType
122  blockType (AutomergeBlock (ImageBlockMarker) _ _) = ImageType
123  blockType (AutomergeBlock (NoteRefMarker _) _ _) = NoteRefType
124  blockType (AutomergeBlock (NoteContentMarker _) _ _) = NoteContentType
125  
126  data Span
127    = BlockSpan BlockSpan
128    | TextSpan TextSpan
129    deriving (Show, Eq)
130  
131  instance FromJSON Span where
132    parseJSON = withObject "AutomergeSpan" $ \v -> do
133      elementType <- (v .: "type" :: Parser String)
134      case elementType of
135        "block" -> parseBlock v
136        "text" -> parseInline v
137        _ -> fail "Unknown span type"
138  
139  parseBlock :: Object -> Parser Span
140  parseBlock v = do
141    blockData <- v .: "value"
142    bt <- (blockData .: "type" :: Parser BlockType)
143    parents <- (blockData .: "parents" :: Parser [BlockType])
144    embed <- (blockData .: "isEmbed" :: Parser Bool)
145    case bt of
146      ParagraphType -> pure $ BlockSpan $ AutomergeBlock ParagraphMarker parents embed
147      HeadingType -> do
148        attrs <- blockData .: "attrs"
149        level <- attrs .: "level"
150        pure $ BlockSpan $ AutomergeBlock (HeadingMarker $ Heading $ HeadingLevel level) parents embed
151      CodeBlockType -> pure $ BlockSpan $ AutomergeBlock CodeBlockMarker parents embed
152      BlockQuoteType -> pure $ BlockSpan $ AutomergeBlock BlockQuoteMarker parents embed
153      OrderedListItemType -> pure $ BlockSpan $ AutomergeBlock OrderedListItemMarker parents embed
154      UnorderedListItemType -> pure $ BlockSpan $ AutomergeBlock UnorderedListItemMarker parents embed
155      ImageType -> pure $ BlockSpan $ AutomergeBlock ImageBlockMarker parents embed
156      NoteRefType -> do
157        attrs <- blockData .: "attrs"
158        noteId <- attrs .: "id"
159        pure $ BlockSpan $ AutomergeBlock (NoteRefMarker noteId) parents embed
160      NoteContentType -> do
161        attrs <- blockData .: "attrs"
162        noteId <- attrs .: "id"
163        pure $ BlockSpan $ AutomergeBlock (NoteContentMarker noteId) parents embed
164  
165  parseInline :: Object -> Parser Span
166  parseInline v = do
167    parsedValue <- v .: "value"
168    marksKeyMap <- v .:? "marks" .!= KM.empty
169    parsedMarks <- parseMarks marksKeyMap
170    pure $ TextSpan $ AutomergeText parsedValue parsedMarks
171  
172  parseMarks :: KM.KeyMap Value -> Parser [Mark]
173  parseMarks = mapM parseMark . filterNonNull . KM.toList
174    where
175      filterNonNull = filter (\(_, v) -> v /= Null)
176  
177  parseMark :: (K.Key, Value) -> Parser Mark
178  parseMark (k, String txt)
179    | K.toText k == "link" = parseStringifiedObject txt >>= (pure . LinkMark)
180  parseMark (k, Bool True) = case K.toText k of
181    "strong" -> pure Strong
182    "em" -> pure Emphasis
183    "code" -> pure Code
184    _ -> fail $ "Unexpected mark with boolean value: " ++ T.unpack (K.toText k)
185  parseMark _ = fail "Invalid format in marks"
186  
187  parseAutomergeSpans :: BL.ByteString -> Either String [Span]
188  parseAutomergeSpans = eitherDecode
189  
190  parseAutomergeSpansText :: T.Text -> Either String [Span]
191  parseAutomergeSpansText = eitherDecodeStrictText
192  
193  instance ToJSON Span where
194    toJSON (BlockSpan (AutomergeBlock marker parents embed)) = case marker of
195      ParagraphMarker ->
196        object
197          [ "type" .= T.pack "block",
198            "value"
199              .= object
200                [ "isEmbed" .= embed,
201                  "parents" .= parents,
202                  "type" .= T.pack "paragraph",
203                  "attrs" .= (KM.empty :: KM.KeyMap T.Text)
204                ]
205          ]
206      HeadingMarker (Heading (HeadingLevel level)) ->
207        object
208          [ "type" .= T.pack "block",
209            "value"
210              .= object
211                [ "isEmbed" .= embed,
212                  "parents" .= parents,
213                  "type" .= T.pack "heading",
214                  "attrs" .= object ["level" .= level]
215                ]
216          ]
217      CodeBlockMarker ->
218        object
219          [ "type" .= T.pack "block",
220            "value"
221              .= object
222                [ "isEmbed" .= embed,
223                  "parents" .= parents,
224                  "type" .= T.pack "code-block",
225                  "attrs" .= (KM.empty :: KM.KeyMap T.Text)
226                ]
227          ]
228      BlockQuoteMarker ->
229        object
230          [ "type" .= T.pack "block",
231            "value"
232              .= object
233                [ "isEmbed" .= embed,
234                  "parents" .= ([] :: [T.Text]),
235                  "type" .= T.pack "blockquote",
236                  "attrs" .= (KM.empty :: KM.KeyMap T.Text)
237                ]
238          ]
239      OrderedListItemMarker ->
240        object
241          [ "type" .= T.pack "block",
242            "value"
243              .= object
244                [ "isEmbed" .= embed,
245                  "parents" .= parents,
246                  "type" .= T.pack "ordered-list-item",
247                  "attrs" .= (KM.empty :: KM.KeyMap T.Text)
248                ]
249          ]
250      UnorderedListItemMarker ->
251        object
252          [ "type" .= T.pack "block",
253            "value"
254              .= object
255                [ "isEmbed" .= embed,
256                  "parents" .= parents,
257                  "type" .= T.pack "unordered-list-item",
258                  "attrs" .= (KM.empty :: KM.KeyMap T.Text)
259                ]
260          ]
261      ImageBlockMarker ->
262        object
263          [ "type" .= T.pack "block",
264            "value"
265              .= object
266                [ "isEmbed" .= embed,
267                  "parents" .= parents,
268                  "type" .= T.pack "image",
269                  "attrs" .= (KM.empty :: KM.KeyMap T.Text)
270                ]
271          ]
272      NoteRefMarker (NoteId noteId) ->
273        object
274          [ "type" .= T.pack "block",
275            "value"
276              .= object
277                [ "isEmbed" .= embed,
278                  "parents" .= parents,
279                  "type" .= T.pack "__ext__note_ref",
280                  "attrs" .= object ["id" .= noteId]
281                ]
282          ]
283      NoteContentMarker (NoteId noteId) ->
284        object
285          [ "type" .= T.pack "block",
286            "value"
287              .= object
288                [ "isEmbed" .= embed,
289                  "parents" .= parents,
290                  "type" .= T.pack "__ext__note_content",
291                  "attrs" .= object ["id" .= noteId]
292                ]
293          ]
294    toJSON (TextSpan (AutomergeText val extractedMarks)) =
295      object $
296        [ "type" .= T.pack "text",
297          "value" .= val
298        ]
299          <> ["marks" .= KM.fromList (map markToKeyVal extractedMarks) | not (null extractedMarks)]
300      where
301        markToKeyVal mark = case mark of
302          Strong -> (K.fromText "strong", Bool True)
303          Emphasis -> (K.fromText "em", Bool True)
304          LinkMark link -> (K.fromText "link", String $ stringifyObject link)
305          Code -> (K.fromText "code", Bool True)
306  
307  toJSONText :: [Span] -> T.Text
308  toJSONText = decodeUtf8 . BSL8.toStrict . encode
309  
310  takeUntilNonEmbedBlockSpan :: [Span] -> [Span]
311  takeUntilNonEmbedBlockSpan [] = []
312  takeUntilNonEmbedBlockSpan (x : xs) = case x of
313    BlockSpan (AutomergeBlock _ _ False) -> []
314    _ -> x : takeUntilNonEmbedBlockSpan xs
315  
316  takeUntilNextSameBlockTypeSibling :: BlockSpan -> [Span] -> [Span]
317  takeUntilNextSameBlockTypeSibling _ [] = []
318  takeUntilNextSameBlockTypeSibling bl (x : xs) = case x of
319    BlockSpan blockSpan | (isSibling blockSpan bl && blockType blockSpan == blockType bl) -> []
320    _ -> x : takeUntilNextSameBlockTypeSibling bl xs
321  
322  isTopLevelBlock :: BlockSpan -> Bool
323  isTopLevelBlock (AutomergeBlock _ parents _) = null parents
324  
325  isParent :: Maybe BlockSpan -> BlockSpan -> Bool
326  isParent (Just parentBlock) potentialChildBlock = lastParentMatches parentBlockType potentialChildParents && isProperPrefix parentParents potentialChildParents
327    where
328      parentBlockType = blockType parentBlock
329      parentParents = parentTypes parentBlock
330      potentialChildParents = parentTypes potentialChildBlock
331  isParent Nothing blockSpan = isTopLevelBlock blockSpan
332  
333  isSibling :: BlockSpan -> BlockSpan -> Bool
334  isSibling (AutomergeBlock _ block1Parents _) (AutomergeBlock _ block2Parents _) = block1Parents == block2Parents
335  
336  lastParentMatches :: BlockType -> [BlockType] -> Bool
337  lastParentMatches parentBlockType potentialChildParents = case unsnoc potentialChildParents of
338    Nothing -> False
339    Just (_, lastParentOfCandidate) -> parentBlockType == lastParentOfCandidate
340  
341  isSiblingListItem :: BlockSpan -> BlockSpan -> Bool
342  isSiblingListItem (AutomergeBlock UnorderedListItemMarker listItem1Parents _) (AutomergeBlock UnorderedListItemMarker listItem2Parents _) = listItem1Parents == listItem2Parents
343  isSiblingListItem (AutomergeBlock OrderedListItemMarker listItem1Parents _) (AutomergeBlock OrderedListItemMarker listItem2Parents _) = listItem1Parents == listItem2Parents
344  isSiblingListItem (AutomergeBlock _ _ _) (AutomergeBlock _ _ _) = False
345  
346  isProperPrefix :: [BlockType] -> [BlockType] -> Bool
347  isProperPrefix _ [] = False
348  isProperPrefix parents potentialChildParents = parents == (init potentialChildParents)