module Nbparts.Unpack.Sources.Markdown where

import Control.Arrow qualified as Arrow
import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as LazyByteString
import Data.Function ((&))
import Data.Map qualified as Map
import Data.Maybe qualified as Maybe
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Nbparts.Types
  ( CellMarker (CellMarker),
    CellSource (CellSource),
    CellType (Code, Markdown, Raw),
    UnembeddedMimeAttachments (UnembeddedMimeAttachments),
    UnembeddedMimeBundle (UnembeddedMimeBundle),
    UnembeddedMimeData (BinaryData),
    UnpackError (UnpackParseMarkdownError),
  )
import Nbparts.Util.Map qualified as MapUtil
import Nbparts.Util.Markdown qualified as MarkdownUtil
import Nbparts.Util.Text qualified as TextUtil

sourcesToMarkdown :: Text -> [CellSource] -> Either UnpackError Text
sourcesToMarkdown :: Text -> [CellSource] -> Either UnpackError Text
sourcesToMarkdown Text
lang [CellSource]
sources = do
  [Text]
texts <- (CellSource -> Either UnpackError Text)
-> [CellSource] -> Either UnpackError [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Text -> CellSource -> Either UnpackError Text
sourceToMarkdown Text
lang) [CellSource]
sources
  Text -> Either UnpackError Text
forall a. a -> Either UnpackError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either UnpackError Text)
-> Text -> Either UnpackError Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n") [Text]
texts)

sourceToMarkdown :: Text -> CellSource -> Either UnpackError Text
sourceToMarkdown :: Text -> CellSource -> Either UnpackError Text
sourceToMarkdown Text
_ (CellSource Text
cellId cellType :: CellType
cellType@CellType
Markdown [Text]
source Maybe UnembeddedMimeAttachments
maybeAttachments) = do
  -- NOTE: Remember that the elements in `source` have trailing newlines.
  let mdText :: Text
mdText = [Text] -> Text
Text.concat [Text]
source
  let mdLines :: [Text]
mdLines = Text -> [Text]
Text.lines Text
mdText

  Blocks
mdAst <- Text -> Either ParseError Blocks
MarkdownUtil.parseMarkdown Text
mdText Either ParseError Blocks
-> (Either ParseError Blocks -> Either UnpackError Blocks)
-> Either UnpackError Blocks
forall a b. a -> (a -> b) -> b
& (ParseError -> UnpackError)
-> Either ParseError Blocks -> Either UnpackError Blocks
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
Arrow.left ParseError -> UnpackError
UnpackParseMarkdownError

  let escapesReplacements :: [((Int, Int), Text)]
escapesReplacements = (Text -> Text) -> [Text] -> Blocks -> [((Int, Int), Text)]
MarkdownUtil.commentChangesWith Text -> Text
escapeComments [Text]
mdLines Blocks
mdAst
  let attachmentReplacements :: [((Int, Int), Text)]
attachmentReplacements = case Maybe UnembeddedMimeAttachments
maybeAttachments of
        Just UnembeddedMimeAttachments
attachments ->
          (Text -> Maybe Text) -> [Text] -> Blocks -> [((Int, Int), Text)]
MarkdownUtil.attachmentChangesWith
            ((String -> Text) -> Maybe String -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Text.pack (Maybe String -> Maybe Text)
-> (Text -> Maybe String) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnembeddedMimeAttachments -> Text -> Maybe String
lookupAttachmentFilePath UnembeddedMimeAttachments
attachments)
            [Text]
mdLines
            Blocks
mdAst
        Maybe UnembeddedMimeAttachments
Nothing -> []
  let textReplacements :: [((Int, Int), Text)]
textReplacements = [((Int, Int), Text)]
escapesReplacements [((Int, Int), Text)]
-> [((Int, Int), Text)] -> [((Int, Int), Text)]
forall a. Semigroup a => a -> a -> a
<> [((Int, Int), Text)]
attachmentReplacements

  -- Safety: The replacements do not overlap.
  let fixedMdText :: Text
fixedMdText = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [((Int, Int), Text)] -> Maybe Text
TextUtil.replaceSlices Text
mdText [((Int, Int), Text)]
textReplacements

  Text -> Either UnpackError Text
forall a. a -> Either UnpackError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either UnpackError Text)
-> Text -> Either UnpackError Text
forall a b. (a -> b) -> a -> b
$ CellMarker -> Text
mkCellMarkerComment (Text -> CellType -> Maybe UnembeddedMimeAttachments -> CellMarker
CellMarker Text
cellId CellType
cellType Maybe UnembeddedMimeAttachments
maybeAttachments) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fixedMdText
sourceToMarkdown Text
_ (CellSource Text
cellId cellType :: CellType
cellType@CellType
Raw [Text]
source Maybe UnembeddedMimeAttachments
_) =
  Text -> Either UnpackError Text
forall a. a -> Either UnpackError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either UnpackError Text)
-> Text -> Either UnpackError Text
forall a b. (a -> b) -> a -> b
$
    Text -> [Text] -> Text
Text.intercalate
      Text
"\n"
      [ CellMarker -> Text
mkCellMarkerComment (Text -> CellType -> Maybe UnembeddedMimeAttachments -> CellMarker
CellMarker Text
cellId CellType
cellType Maybe UnembeddedMimeAttachments
forall a. Maybe a
Nothing),
        Text
"```",
        [Text] -> Text
Text.concat [Text]
source,
        Text
"```"
      ]
sourceToMarkdown Text
lang (CellSource Text
cellId cellType :: CellType
cellType@CellType
Code [Text]
source Maybe UnembeddedMimeAttachments
_) =
  Text -> Either UnpackError Text
forall a. a -> Either UnpackError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either UnpackError Text)
-> Text -> Either UnpackError Text
forall a b. (a -> b) -> a -> b
$
    Text -> [Text] -> Text
Text.intercalate
      Text
"\n"
      [ CellMarker -> Text
mkCellMarkerComment (Text -> CellType -> Maybe UnembeddedMimeAttachments -> CellMarker
CellMarker Text
cellId CellType
cellType Maybe UnembeddedMimeAttachments
forall a. Maybe a
Nothing),
        Text
"```" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lang,
        [Text] -> Text
Text.concat [Text]
source,
        Text
"```"
      ]

mkCellMarkerComment :: CellMarker -> Text
mkCellMarkerComment :: CellMarker -> Text
mkCellMarkerComment CellMarker
cm =
  Text -> [Text] -> Text
Text.intercalate
    Text
" "
    [ Text
"<!--",
      Text
"nbparts:cell",
      Text -> Text
escapeCellMarkerContent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
LazyByteString.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CellMarker -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
Aeson.encode CellMarker
cm,
      Text
"-->"
    ]

escapeCellMarkerContent :: Text -> Text
escapeCellMarkerContent :: Text -> Text
escapeCellMarkerContent = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"-->" Text
"-\\->" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"\\" Text
"\\\\"

escapeComments :: Text -> Text
escapeComments :: Text -> Text
escapeComments = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"nbparts:cell" Text
"\\nbparts:cell" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"\\" Text
"\\\\"

lookupAttachmentFilePath :: UnembeddedMimeAttachments -> Text -> Maybe FilePath
lookupAttachmentFilePath :: UnembeddedMimeAttachments -> Text -> Maybe String
lookupAttachmentFilePath (UnembeddedMimeAttachments Map Text UnembeddedMimeBundle
attachments) Text
target = do
  Text
attachmentName <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"attachment:" Text
target

  -- TODO: Should warn if the attachment can't be found.
  (UnembeddedMimeBundle Map Text UnembeddedMimeData
mimeBundle) <- Text -> Map Text UnembeddedMimeBundle -> Maybe UnembeddedMimeBundle
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
attachmentName Map Text UnembeddedMimeBundle
attachments

  -- The mime bundle should only have 1 entry, but just in case it doesn't,
  -- we find the first entry whose mime type starts with "image".
  UnembeddedMimeData
mimedata <- Text -> Map Text UnembeddedMimeData -> Maybe UnembeddedMimeData
forall v. Text -> Map Text v -> Maybe v
MapUtil.lookupByKeyPrefix Text
"image" Map Text UnembeddedMimeData
mimeBundle
  case UnembeddedMimeData
mimedata of
    BinaryData String
fp -> String -> Maybe String
forall a. a -> Maybe a
Just String
fp
    UnembeddedMimeData
_ -> Maybe String
forall a. Maybe a
Nothing