{-# LANGUAGE OverloadedStrings #-}
module Text.Gemini.Markdown
(
encode
, prettyItem
, encodeItem
, 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 :: 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
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
"```"]
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
"```"]
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
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]
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
| 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
'*']
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
'*')]
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)