{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Text.Gemini.Markdown
-- Copyright   :  (c) Sena, 2024
-- License     :  AGPL-3.0-or-later
--
-- Maintainer  :  Sena <jn-sena@proton.me>
-- Stability   :  stable
-- Portability :  portable
--
-- A tiny Gemtext to Markdown converter for gemmula.
--
-- Encodes parsed Gemtext documents and lines as Markdown 'Text'.
-- Follows the [CommonMark specification](https://spec.commonmark.org/current).

module Text.Gemini.Markdown
  ( -- * Encoding documents
    encode
    -- * Encoding single items
  , prettyItem
  , encodeItem
    -- * Rewriting links
  , rewriteLink
  ) where

import Control.Monad (join)
import Control.Arrow ((***), second)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromMaybe, isNothing)
import Data.Either (isRight)
import Data.List (groupBy, intercalate)
import Data.Char (isDigit)
import Data.Bool (bool)
import qualified Text.URI as URI

import Text.Gemini (GemDocument, GemItem (..))


-- | Encode parsed 'GemDocument' as a Markdown file.
-- The output 'Text' uses LF-endings. Uses the 'prettyItem' function below.
--
-- Valid Markdown characters are escaped before encoding.
--
-- The adjacent links are grouped together in a paragraph to make them look pretty.
--
-- Empty 'GemText's and 'GemList's are ignored.
encode :: GemDocument -> Text
encode :: GemDocument -> Text
encode = [Text] -> Text
T.unlines ([Text] -> Text) -> (GemDocument -> [Text]) -> GemDocument -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GemItem -> Text) -> GemDocument -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map GemItem -> Text
prettyItem (GemDocument -> [Text])
-> (GemDocument -> GemDocument) -> GemDocument -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GemDocument -> [GemDocument] -> GemDocument
forall a. [a] -> [[a]] -> [a]
intercalate [Text -> GemItem
GemText Text
""] ([GemDocument] -> GemDocument)
-> (GemDocument -> [GemDocument]) -> GemDocument -> GemDocument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GemItem -> GemItem -> Bool) -> GemDocument -> [GemDocument]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy GemItem -> GemItem -> Bool
links (GemDocument -> [GemDocument])
-> (GemDocument -> GemDocument) -> GemDocument -> [GemDocument]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GemItem -> Bool) -> GemDocument -> GemDocument
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (GemItem -> Bool) -> GemItem -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GemItem -> Bool
empty)
    where empty :: GemItem -> Bool
          empty :: GemItem -> Bool
empty (GemText Text
line) = Text -> Bool
T.null (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text
line
          empty (GemList [Text]
list) = [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
list
          empty GemItem
_ = Bool
False

          links :: GemItem -> GemItem -> Bool
          links :: GemItem -> GemItem -> Bool
links (GemLink Text
_ Maybe Text
_) (GemLink Text
_ Maybe Text
_) = Bool
True
          links GemItem
_ GemItem
_ = Bool
False


-- | Encode a /single/ parsed 'GemItem' as Markdown text.
-- The output 'Text' uses LF-endings and might be multiple lines.
--
-- Valid Markdown characters are escaped before encoding.
--
-- Unlike 'encodeItem', long lines (> 80) will be split to multiple lines to
-- make it look prettier. The link items are also put in a seperate line to make them
-- look nice.
--
-- /Beware/ that the output text doesn't end with a newline.
prettyItem :: GemItem -> Text
prettyItem :: GemItem -> Text
prettyItem (GemText Text
line) = Maybe Text -> Text -> Text
multiline Maybe Text
forall a. Maybe a
Nothing (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeContent Text
line
prettyItem (GemLink Text
link Maybe Text
desc) = let desc' :: Text
desc' = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Text
escapeContent Text
link) (Maybe Text -> Text -> Text
multiline Maybe Text
forall a. Maybe a
Nothing (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeContent) Maybe Text
desc
                                  in Text
" => [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"](" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
link Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")  "
prettyItem (GemHeading Int
level Text
text) = Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
level Int
6) Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeContent Text
text
prettyItem (GemList [Text]
list) = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
" * " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text -> Text
multiline Maybe Text
forall a. Maybe a
Nothing (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeContent) [Text]
list
prettyItem (GemQuote Text
text) = Maybe Text -> Text -> Text
multiline (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
" > ") (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeContent Text
text
prettyItem (GemPre [Text]
text Maybe Text
alt) = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text
"```" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
alt] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
escapePre [Text]
text [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"```"]

-- | Encode a /single/ parsed 'GemItem' as Markdown text.
-- The output 'Text' uses LF-endings and might be multiple lines.
--
-- Valid Markdown characters are escaped before encoding.
--
-- /Beware/ that the output text doesn't end with a newline.
encodeItem :: GemItem -> Text
encodeItem :: GemItem -> Text
encodeItem (GemText Text
line) = Text -> Text
escapePrefixes (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeContent Text
line
encodeItem (GemLink Text
link Maybe Text
desc) = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeContent (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
link Maybe Text
desc) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"](" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
link Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
encodeItem (GemHeading Int
level Text
text) = Int -> Text -> Text
T.replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
level Int
6) Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeContent Text
text
encodeItem (GemList [Text]
list) = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
" * " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeContent) [Text]
list
encodeItem (GemQuote Text
text) = Text
" > " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeContent Text
text
encodeItem (GemPre [Text]
text Maybe Text
alt) = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text
"```" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
alt] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
escapePre [Text]
text [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"```"]


-- | Rewrite @.gmi@ links as @.md@ links.
--
-- /Beware/ that this only applies to local 'GemLink's.
-- For rewriting non-local links as @http@, see 'Text.Gemini.Web.webifyLink'.
rewriteLink :: GemItem -> GemItem
rewriteLink :: GemItem -> GemItem
rewriteLink (GemLink Text
link Maybe Text
desc)
    | Maybe (Bool, NonEmpty (RText 'PathPiece)) -> Bool
forall a. Maybe a -> Bool
isNothing (URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
uri) Bool -> Bool -> Bool
|| Either Bool Authority -> Bool
forall a b. Either a b -> Bool
isRight (URI -> Either Bool Authority
URI.uriAuthority URI
uri) = Text -> Maybe Text -> GemItem
GemLink Text
link Maybe Text
desc
    | Bool
otherwise = Text -> Maybe Text -> GemItem
GemLink (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
link (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".md") (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripSuffix Text
".gmi" Text
link) Maybe Text
desc
    where uri :: URI
uri = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe URI
URI.emptyURI (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ Text -> Maybe URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI Text
link
rewriteLink GemItem
item = GemItem
item


-- Split the text to multiple lines if the text is longer than 80 characters.
-- If given, adds the prefix to the beginning of every line.
-- Escapes the valid prefixes of every line if the text has any.
multiline :: Maybe Text -> Text -> Text
multiline :: Maybe Text -> Text -> Text
multiline Maybe Text
pre Text
text = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text)
-> (Text -> Text -> Text) -> Maybe Text -> Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text -> Text
forall a. a -> a
id Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) Maybe Text
pre (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapePrefixes) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> [Text] -> [Text]
split [] [] ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
text
    where split :: [Text] -> [Text] -> [Text] -> [Text]
          split :: [Text] -> [Text] -> [Text] -> [Text]
split [Text]
line [Text]
ls (Text
w:[Text]
ws)
              | Text -> Int
T.length ([Text] -> Text
T.unwords [Text]
line) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
80 = [Text] -> [Text] -> [Text] -> [Text]
split ([Text]
line [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
w]) [Text]
ls [Text]
ws
              | Bool
otherwise = [Text] -> [Text] -> [Text] -> [Text]
split [Text
w] ([Text]
ls [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [[Text] -> Text
T.unwords [Text]
line]) [Text]
ws
          split [Text]
line [Text]
ls [] = [Text]
ls [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [[Text] -> Text
T.unwords [Text]
line]


-- Escapes the line prefixes such as list items and quotes.
escapePrefixes :: Text -> Text
escapePrefixes :: Text -> Text
escapePrefixes Text
text = (Char -> Text -> Text) -> Text -> [Char] -> Text
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> Text -> Text
escapePrefix Text
text [Char]
chars
    where escapePrefix :: Char -> Text -> Text
          escapePrefix :: Char -> Text -> Text
escapePrefix Char
c Text
t
              | Text -> Bool
T.null Text
end = Text
t
              -- Ordered lists
              | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool Text
t (Text
pre Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end) ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
before Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
before))
              | Bool
otherwise = Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool Text
t (Text
pre Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end) ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
before)
              where (Text
pre, Text
end) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) Text
t
                    before :: [Char]
before = Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.stripStart (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text
pre

          chars :: [Char]
chars = [Char
'.', Char
'-', Char
'+', Char
'#', Char
'>', Char
'*']

-- Escapes the content of the text, such as the backslashes; as well as the
-- surround characters, such as emphasis, links and codeblocks.
escapeContent :: Text -> Text
escapeContent :: Text -> Text
escapeContent Text
text = ((Char, Char) -> Text -> Text) -> Text -> [(Char, Char)] -> Text
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Char, Char) -> Text -> Text
escapeSurround (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\\" Text
"\\\\" Text
text) [(Char, Char)]
chars
    where escapeSurround :: (Char, Char) -> Text -> Text
          escapeSurround :: (Char, Char) -> Text -> Text
escapeSurround del :: (Char, Char)
del@(Char
op, Char
cl) Text
t
              | Text -> Bool
T.null Text
t = Text
t
              | Bool
otherwise =
                    let (Text
pre, (Text
ins, Text
post)) = (Text -> (Text, Text)) -> (Text, Text) -> (Text, (Text, Text))
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
cl) (Text -> (Text, Text)) -> (Text -> Text) -> Text -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
1 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ")) ((Text, Text) -> (Text, (Text, Text)))
-> (Text, Text) -> (Text, (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
op) Text
t
                        (Text
op', Text
cl') = ((Char -> Text) -> (Char -> Text) -> (Char, Char) -> (Text, Text))
-> (Char -> Text) -> (Char, Char) -> (Text, Text)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Char -> Text) -> (Char -> Text) -> (Char, Char) -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) ((Text
"\\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Char -> Text) -> Char -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton) (Char, Char)
del
                     in Text
pre Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.dropEnd Int
1 (if Text -> Bool
T.null Text
post
                                            then Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool (Char -> Text
T.singleton Char
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ins) Text
ins (Text -> Bool
T.null Text
ins)
                                            else Text
op' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ins Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cl' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char, Char) -> Text -> Text
escapeSurround (Char, Char)
del (Int -> Text -> Text
T.drop Int
1 Text
post))

          chars :: [(Char, Char)]
chars = [(Char
'~', Char
'~'), (Char
'`', Char
'`'), (Char
'(', Char
')'), (Char
'<', Char
'>'), (Char
'[', Char
']'), (Char
'{', Char
'}'), (Char
'_', Char
'_'), (Char
'*', Char
'*')]

-- Escapes the preformatted delimiter inside a preformatted text.
escapePre :: Text -> Text
escapePre :: Text -> Text
escapePre Text
text = Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"```" Text
"    ```" Text
text) Text
text (Text -> Bool
T.null Text
text)