Zim.hs

-- | Conversion from Zim wiki markup to Markdown.
module ZimToMarkdown.Zim (
    convertZimToMarkdown,
    convertZimToMarkdownWithAssets,
    convertZimToMarkdownWithAssetsAndFormatting,
    convertZimToMarkdownWithFormatting,
    zimImagePaths,
) where

import Data.Char (isAlpha, isDigit)
import Data.List (nub, sort)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import System.FilePath (takeBaseName)

import ZimToMarkdown.Domain (FormattingMode (..), MarkdownDocument (..), ZimPage (..))
import ZimToMarkdown.Inline (
    breakOnFirstMarker,
    enclosed,
    italicBoundary,
    renderInlineCode,
    renderMarkdownPath,
 )
import ZimToMarkdown.Links (LinkContext, renderZimLink)
import ZimToMarkdown.Table (
    isTableStart,
    normalizeTable,
    takeTableBlock,
 )

-- | Converts a Zim page into Markdown.
convertZimToMarkdown :: LinkContext -> ZimPage -> MarkdownDocument
convertZimToMarkdown = convertZimToMarkdownWithFormatting HtmlFormatting

{- | Converts a Zim page into Markdown, choosing how inline formatting without
a Markdown counterpart is rendered.
-}
convertZimToMarkdownWithFormatting ::
    FormattingMode ->
    LinkContext ->
    ZimPage ->
    MarkdownDocument
convertZimToMarkdownWithFormatting formatting context =
    convertZimToMarkdownWithAssetsAndFormatting formatting context Map.empty

{- | Converts a Zim page into Markdown, rewriting images to the targets the
notebook conversion prepared for them.
-}
convertZimToMarkdownWithAssets ::
    LinkContext ->
    Map.Map Text Text ->
    ZimPage ->
    MarkdownDocument
convertZimToMarkdownWithAssets =
    convertZimToMarkdownWithAssetsAndFormatting HtmlFormatting

{- | Converts a Zim page into Markdown with prepared image targets and a
formatting mode for inline markup that Markdown cannot express.
-}
convertZimToMarkdownWithAssetsAndFormatting ::
    FormattingMode ->
    LinkContext ->
    Map.Map Text Text ->
    ZimPage ->
    MarkdownDocument
convertZimToMarkdownWithAssetsAndFormatting formatting context assets (ZimPage content) =
    let pageLines =
            Text.splitOn
                "\n"
                (stripZimHeader (normalizeNewlines content))
        headingMap = buildHeadingMap pageLines
     in MarkdownDocument
            ( Text.intercalate
                "\n"
                (renderBlocks formatting context assets headingMap pageLines)
            )

stripZimHeader :: Text -> Text
stripZimHeader content =
    let headerLines = Text.splitOn "\n" content
        remaining = dropWhile isMetadataLine headerLines
     in if length remaining == length headerLines
            then content
            else Text.intercalate "\n" (dropWhile isBlank remaining)

isMetadataLine :: Text -> Bool
isMetadataLine line =
    let key = Text.toLower (Text.strip (fst (Text.breakOn ":" line)))
     in key `elem` metadataKeys

metadataKeys :: [Text]
metadataKeys =
    [ "content-type"
    , "wiki-format"
    , "creation-date"
    , "modification-date"
    ]

isBlank :: Text -> Bool
isBlank = Text.null . Text.strip

{- | Compresses the heading levels present in a page into consecutive
Markdown levels starting at one.
-}
buildHeadingMap :: [Text] -> Map.Map Int Int
buildHeadingMap pageLines =
    Map.fromList
        (zip (sort (nub (collectHeadingLevels pageLines))) [1 ..])

collectHeadingLevels :: [Text] -> [Int]
collectHeadingLevels = go OutsideVerbatim
  where
    go _ [] = []
    go state (line : rest)
        | isVerbatimDelimiter line = go (toggleState state) rest
        | state == InsideVerbatim = go InsideVerbatim rest
        | Just (level, _) <- parseHeading line =
            level : go OutsideVerbatim rest
        | otherwise = go OutsideVerbatim rest

normalizeNewlines :: Text -> Text
normalizeNewlines =
    Text.replace "\r" "\n" . Text.replace "\r\n" "\n"

data BlockState
    = OutsideVerbatim
    | InsideVerbatim
    deriving (Eq)

renderBlocks :: FormattingMode -> LinkContext -> Map.Map Text Text -> Map.Map Int Int -> [Text] -> [Text]
renderBlocks formatting context assets headingMap = go OutsideVerbatim
  where
    go _ [] = []
    go state (line : rest)
        | isVerbatimDelimiter line =
            "```" : go (toggleState state) rest
        | state == InsideVerbatim =
            line : go InsideVerbatim rest
        | isTableStart line =
            let (block, remaining) = takeTableBlock (line : rest)
             in normalizeTable block <> go OutsideVerbatim remaining
        | otherwise =
            renderLine formatting context assets headingMap line : go OutsideVerbatim rest

toggleState :: BlockState -> BlockState
toggleState OutsideVerbatim = InsideVerbatim
toggleState InsideVerbatim = OutsideVerbatim

isVerbatimDelimiter :: Text -> Bool
isVerbatimDelimiter line = Text.strip line == "'''"

renderLine :: FormattingMode -> LinkContext -> Map.Map Text Text -> Map.Map Int Int -> Text -> Text
renderLine formatting context assets headingMap line
    | Text.null (Text.strip line) = line
    | Just (level, content) <- parseHeading line =
        let markdownLevel =
                min 6 (Map.findWithDefault level level headingMap)
         in Text.replicate markdownLevel "#"
                <> " "
                <> convertInline formatting context assets content
    | isHorizontalRule line = "---"
    | Just listLine <- parseListLine line =
        renderListLine formatting context assets listLine
    | Just (depth, content) <- parseIndentedBlock line =
        Text.replicate depth "> "
            <> renderLine formatting context assets headingMap content
    | otherwise = convertInline formatting context assets line

isHorizontalRule :: Text -> Bool
isHorizontalRule line =
    let trimmed = Text.strip line
     in Text.length trimmed >= 5 && Text.all (== '-') trimmed

parseIndentedBlock :: Text -> Maybe (Int, Text)
parseIndentedBlock line =
    let (tabs, afterTabs) = Text.span (== '\t') line
        (spaces, rest) = Text.span (== ' ') afterTabs
        depth = Text.length tabs + Text.length spaces `div` 4
     in if depth == 0
            then Nothing
            else Just (depth, rest)

parseHeading :: Text -> Maybe (Int, Text)
parseHeading line =
    let opening = Text.takeWhile (== '=') line
        count = Text.length opening
     in if count >= 2 && count <= 6
            then
                let afterOpening = Text.drop count line
                    closing = Text.takeWhileEnd (== '=') afterOpening
                    content =
                        Text.strip
                            (Text.dropEnd (Text.length closing) afterOpening)
                 in if Text.length closing == count && not (Text.null content)
                        then Just (7 - count, content)
                        else Nothing
            else Nothing

data ListMarker
    = Bullet
    | Numbered
    | Alphabetic
    | Task Bool
    deriving (Eq)

data ListLine = ListLine
    { listIndent :: Text
    , listMarker :: ListMarker
    , listContent :: Text
    }

parseListLine :: Text -> Maybe ListLine
parseListLine line =
    let (indent, rest) = Text.span isIndent line
     in case parseMarker rest of
            Nothing -> Nothing
            Just (marker, content) ->
                Just
                    ListLine
                        { listIndent = indent
                        , listMarker = marker
                        , listContent = content
                        }
  where
    isIndent character = character == ' ' || character == '\t'

parseMarker :: Text -> Maybe (ListMarker, Text)
parseMarker text
    | Just rest <- Text.stripPrefix "[ ] " text = Just (Task False, rest)
    | Just rest <- Text.stripPrefix "[*] " text = Just (Task True, rest)
    | Just rest <- Text.stripPrefix "[x] " text = Just (Task True, rest)
    | Just rest <- Text.stripPrefix "[X] " text = Just (Task True, rest)
    | Just rest <- Text.stripPrefix "[>] " text = Just (Task True, rest)
    | Just rest <- Text.stripPrefix "[<] " text = Just (Task True, rest)
    | Just rest <- Text.stripPrefix "* " text = Just (Bullet, rest)
    | Just rest <- Text.stripPrefix "- " text = Just (Bullet, rest)
    | otherwise = parseOrdered text

parseOrdered :: Text -> Maybe (ListMarker, Text)
parseOrdered text =
    let (digits, afterDigits) = Text.span isDigit text
     in if Text.null digits
            then parseAlphabetic text
            else case Text.stripPrefix ". " afterDigits of
                Just rest -> Just (Numbered, rest)
                Nothing -> parseAlphabetic text

parseAlphabetic :: Text -> Maybe (ListMarker, Text)
parseAlphabetic text =
    case Text.uncons text of
        Just (letter, afterLetter)
            | isAlpha letter
            , Just rest <- Text.stripPrefix ". " afterLetter ->
                Just (Alphabetic, rest)
        _ -> Nothing

renderListLine :: FormattingMode -> LinkContext -> Map.Map Text Text -> ListLine -> Text
renderListLine formatting context assets listLine =
    indentToSpaces (listIndent listLine)
        <> prefix
        <> convertInline formatting context assets (listContent listLine)
  where
    prefix =
        case listMarker listLine of
            Bullet -> "* "
            Numbered -> "1. "
            Alphabetic -> "1. "
            Task False -> "- [ ] "
            Task True -> "- [x] "

indentToSpaces :: Text -> Text
indentToSpaces =
    Text.concatMap
        ( \character ->
            if character == '\t'
                then "  "
                else Text.singleton character
        )

inlineMarkers :: [Text]
inlineMarkers =
    [ "<strong>"
    , "<b>"
    , "<em>"
    , "<i>"
    , "{{id:"
    , "**"
    , "//"
    , "__"
    , "''"
    , "~~"
    , "[["
    , "{{"
    , "_{"
    , "^{"
    ]

convertInline :: FormattingMode -> LinkContext -> Map.Map Text Text -> Text -> Text
convertInline formatting context assets = go
  where
    go text =
        let (plain, marker) = breakOnFirstMarker inlineMarkers text
         in plain
                <> case marker of
                    Nothing -> ""
                    Just suffix -> convertMarker plain suffix

    convertMarker preceding text
        | Just result <-
            enclosed "<strong>" "</strong>" (\inner -> "**" <> go inner <> "**") text =
            keep result
        | Just result <-
            enclosed "<b>" "</b>" (\inner -> "**" <> go inner <> "**") text =
            keep result
        | Just result <-
            enclosed "<em>" "</em>" (\inner -> "*" <> go inner <> "*") text =
            keep result
        | Just result <-
            enclosed "<i>" "</i>" (\inner -> "*" <> go inner <> "*") text =
            keep result
        | Just result <- enclosed "{{id:" "}}" renderAnchor text =
            keep result
        | Just result <-
            enclosed "**" "**" (\inner -> "**" <> go inner <> "**") text =
            keep result
        | italicBoundary preceding
        , Just result <-
            enclosed "//" "//" (\inner -> "*" <> go inner <> "*") text =
            keep result
        | Just result <- enclosed "__" "__" (renderUnsupported "u") text =
            keep result
        | Just result <- enclosed "''" "''" renderInlineCode text =
            keep result
        | Just result <-
            enclosed "~~" "~~" (\inner -> "~~" <> go inner <> "~~") text =
            keep result
        | Just result <-
            enclosed
                "[["
                "]]"
                (renderZimLink context (convertInline formatting context assets))
                text =
            keep result
        | Just result <- enclosed "{{" "}}" (renderImage assets) text =
            keep result
        | Just result <- enclosed "_{" "}" (renderUnsupported "sub") text =
            keep result
        | Just result <- enclosed "^{" "}" (renderUnsupported "sup") text =
            keep result
        | otherwise = Text.take 1 text <> go (Text.drop 1 text)

    keep (rendered, after) = rendered <> go after

    renderUnsupported :: Text -> Text -> Text
    renderUnsupported tag inner =
        case formatting of
            HtmlFormatting -> "<" <> tag <> ">" <> go inner <> "</" <> tag <> ">"
            BoldFormatting -> "**" <> go inner <> "**"
            ItalicFormatting -> "*" <> go inner <> "*"
            StrikeFormatting -> "~~" <> go inner <> "~~"

renderAnchor :: Text -> Text
renderAnchor inner =
    let name = Text.strip inner
     in if Text.null name
            then "{{id:}}"
            else
                "<a id=\""
                    <> Text.replace "\"" "&quot;" name
                    <> "\"></a>"

renderImage :: Map.Map Text Text -> Text -> Text
renderImage assets inner =
    let (pathPart, altPart) = Text.breakOn "|" inner
        path = cleanImagePath pathPart
        target = Map.findWithDefault path path assets
        altText =
            if Text.null altPart
                then Text.pack (takeBaseName (Text.unpack path))
                else Text.strip (Text.drop 1 altPart)
     in if Text.null path
            then "{{" <> inner <> "}}"
            else
                "!["
                    <> Text.replace "]" "\\]" altText
                    <> "]("
                    <> renderMarkdownPath target
                    <> ")"

-- | Removes the Zim display options, such as @?width=512@, from an image path.
cleanImagePath :: Text -> Text
cleanImagePath rawPath =
    let trimmed = Text.strip rawPath
     in Text.strip (Text.takeWhile (/= '?') trimmed)

{- | Lists the image paths referenced by a Zim page, without display options.
Anchors such as @{{id: intro}}@ are not images and are ignored. Verbatim
blocks are skipped, because they are copied to the output unchanged.
-}
zimImagePaths :: ZimPage -> [Text]
zimImagePaths (ZimPage content) =
    concatMap scanLine (outsideVerbatim (Text.splitOn "\n" content))
  where
    outsideVerbatim = go OutsideVerbatim
      where
        go _ [] = []
        go state (line : rest)
            | isVerbatimDelimiter line = go (toggleState state) rest
            | state == InsideVerbatim = go InsideVerbatim rest
            | otherwise = line : go OutsideVerbatim rest

    scanLine text =
        case Text.breakOn "{{" text of
            (_, rest)
                | Text.null rest -> []
                | otherwise ->
                    let afterOpening = Text.drop 2 rest
                        (inner, closing) = Text.breakOn "}}" afterOpening
                        remaining = Text.drop 2 closing
                        path = cleanImagePath (Text.takeWhile (/= '|') inner)
                     in if Text.null closing
                            then scanLine afterOpening
                            else
                                if Text.isPrefixOf "id:" (Text.strip inner) || Text.null path
                                    then scanLine remaining
                                    else path : scanLine remaining