{-# LANGUAGE OverloadedStrings #-}
module Language.Gemini (
-- * Gemini documents
  GeminiDocument
, GeminiLine(..)
-- * Decoding
, decodeGemini
-- * Encoding
, encodeGemini
) where

import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T

import Data.Char (isSpace)
import Data.Int (Int64)

-- Gemini documents
----------------------------

type GeminiDocument = [GeminiLine]

data GeminiLine = LText Text -- ^ Normal text
                | LLink Text (Maybe Text) -- ^ A link with an optional description
                | LPre [Text] -- ^ A preformatted block containing multiple lines
                | LH1 Text -- ^ A first level heading
                | LH2 Text -- ^ A second level heading
                | LH3 Text -- ^ A third level heading
                | LItem Text -- ^ A list item
                | LQuote Text -- ^ A quotation
  deriving (Int -> GeminiLine -> ShowS
[GeminiLine] -> ShowS
GeminiLine -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GeminiLine] -> ShowS
$cshowList :: [GeminiLine] -> ShowS
show :: GeminiLine -> String
$cshow :: GeminiLine -> String
showsPrec :: Int -> GeminiLine -> ShowS
$cshowsPrec :: Int -> GeminiLine -> ShowS
Show, ReadPrec [GeminiLine]
ReadPrec GeminiLine
Int -> ReadS GeminiLine
ReadS [GeminiLine]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [GeminiLine]
$creadListPrec :: ReadPrec [GeminiLine]
readPrec :: ReadPrec GeminiLine
$creadPrec :: ReadPrec GeminiLine
readList :: ReadS [GeminiLine]
$creadList :: ReadS [GeminiLine]
readsPrec :: Int -> ReadS GeminiLine
$creadsPrec :: Int -> ReadS GeminiLine
Read, GeminiLine -> GeminiLine -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GeminiLine -> GeminiLine -> Bool
$c/= :: GeminiLine -> GeminiLine -> Bool
== :: GeminiLine -> GeminiLine -> Bool
$c== :: GeminiLine -> GeminiLine -> Bool
Eq)

-- Decoding
----------------------------

decodeGemini :: Bool -- ^ Whether to allow unix-style line endings (\n)
             -> Text -- ^ Text to parse
             -> GeminiDocument
-- gemini is really simple, so we do not even use a parsing library
decodeGemini :: Bool -> Text -> [GeminiLine]
decodeGemini Bool
allowUnixStyle = [Text] -> [GeminiLine]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
allowUnixStyle then forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
T.lines else forall a. a -> a
id)
                                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"\CR\LF"
  where
    go :: [Text] -> [GeminiLine]
go [] = []
    go (Text
l:[Text]
ls) | Text -> Bool
isPreToggle Text
l = let ([Text]
pres, [Text]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
isPreToggle [Text]
ls
                                 in [Text] -> GeminiLine
LPre [Text]
pres forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go (forall a. Int -> [a] -> [a]
drop Int
1 [Text]
rest)
              | Text
"=>" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Text -> GeminiLine
parseLink (Int64 -> Text -> Text
dropPrefix Int64
2 Text
l) forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go [Text]
ls
              | Text
"###" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Text -> GeminiLine
LH3 (Int64 -> Text -> Text
dropPrefix Int64
3 Text
l) forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go [Text]
ls
              | Text
"##" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Text -> GeminiLine
LH2 (Int64 -> Text -> Text
dropPrefix Int64
2 Text
l) forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go [Text]
ls
              | Text
"#" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Text -> GeminiLine
LH1 (Int64 -> Text -> Text
dropPrefix Int64
1 Text
l) forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go [Text]
ls
              | Text
"* " Text -> Text -> Bool
`T.isPrefixOf` Text
l = Text -> GeminiLine
LItem (Int64 -> Text -> Text
dropPrefix Int64
2 Text
l) forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go [Text]
ls
              | Text
">" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Text -> GeminiLine
LQuote (Int64 -> Text -> Text
dropPrefix Int64
1 Text
l) forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go [Text]
ls
              | Bool
otherwise = Text -> GeminiLine
LText Text
l forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go [Text]
ls

isPreToggle :: Text -> Bool
isPreToggle :: Text -> Bool
isPreToggle = Text -> Text -> Bool
T.isPrefixOf Text
"```"

dropPrefix :: Int64 -> Text -> Text
dropPrefix :: Int64 -> Text -> Text
dropPrefix Int64
n = Text -> Text
T.stripStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Text -> Text
T.drop Int64
n

parseLink :: Text -> GeminiLine
parseLink :: Text -> GeminiLine
parseLink Text
txt = Text -> Maybe Text -> GeminiLine
LLink Text
link forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
desc' then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Text
desc'
  where
    (Text
link, Text
desc) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace Text
txt
    desc' :: Text
desc' = Text -> Text
T.stripStart Text
desc

-- Encoding
----------------------------

encodeGemini :: GeminiDocument -> Text
encodeGemini :: [GeminiLine] -> Text
encodeGemini = Text -> [Text] -> Text
T.intercalate Text
"\CR\LF" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GeminiLine -> Text
encodeLine

encodeLine :: GeminiLine -> Text
encodeLine :: GeminiLine -> Text
encodeLine (LText Text
t) = Text -> Text
escapeLText Text
t
encodeLine (LLink Text
l Maybe Text
desc) = Text
"=> " forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeLink Text
l forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
desc'
  where desc' :: Text
desc' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
T.empty Text -> Text
escapeNewlines Maybe Text
desc
encodeLine (LPre [Text]
ls) = Text -> [Text] -> Text
T.intercalate Text
"\CR\LF" forall a b. (a -> b) -> a -> b
$
  Text
"```" forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
escapeLPre [Text]
ls forall a. Semigroup a => a -> a -> a
<> [Text
"```"]
encodeLine (LH1 Text
t) = Text
"# " forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t
encodeLine (LH2 Text
t) = Text
"## " forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t
encodeLine (LH3 Text
t) = Text
"### " forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t
encodeLine (LItem Text
t) = Text
"* " forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t
encodeLine (LQuote Text
t) = Text
"> " forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t

--- TODO ask about actual escaping rules instead of just using "\\" and stripping newlines
escapeCharacter :: Char
escapeCharacter :: Char
escapeCharacter = Char
' '

escapeLPre :: Text -> Text
escapeLPre :: Text -> Text
escapeLPre = Text -> Text
escapePrePrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeNewlines

escapeLText :: Text -> Text
escapeLText :: Text -> Text
escapeLText = Text -> Text
escapeAnyPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeNewlines

escapeLink :: Text -> Text
-- Ideally spaces should be urlencoded but nonmalicious agents wouldn't put
-- whitespace in a link anyway.
escapeLink :: Text -> Text
escapeLink = (Char -> Char) -> Text -> Text
T.map forall a b. (a -> b) -> a -> b
$ \Char
c -> if Char -> Bool
isSpace Char
c then Char
'+' else Char
c

escapeNewlines :: Text -> Text
escapeNewlines :: Text -> Text
escapeNewlines = (Char -> Char) -> Text -> Text
T.map Char -> Char
crlfToSpace
  where
    crlfToSpace :: Char -> Char
crlfToSpace Char
'\CR' = Char
' '
    crlfToSpace Char
'\LF' = Char
' '
    crlfToSpace Char
c     = Char
c

escapePrePrefix :: Text -> Text
escapePrePrefix :: Text -> Text
escapePrePrefix Text
t | Text
"```" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Char -> Text -> Text
T.cons Char
escapeCharacter Text
t
                  | Bool
otherwise                     = Text
t

escapeAnyPrefix :: Text -> Text
escapeAnyPrefix :: Text -> Text
escapeAnyPrefix Text
t | Text -> Bool
reservedPrefix Text
t = Char -> Text -> Text
T.cons Char
escapeCharacter Text
t
                  | Bool
otherwise        = Text
t

reservedPrefix :: Text -> Bool
reservedPrefix :: Text -> Bool
reservedPrefix Text
t = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
t)
  [ Text
"=>"
  , Text
"```"
  , Text
"#"
  , Text
"* "
  , Text
">"
  ]