{-# LANGUAGE OverloadedStrings #-}
module Language.Gemini (
GeminiDocument
, GeminiLine(..)
, decodeGemini
, encodeGemini
) where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import Data.Char (isSpace)
import Data.Int (Int64)
type GeminiDocument = [GeminiLine]
data GeminiLine = LText Text
| LLink Text (Maybe Text)
| LPre [Text]
| LH1 Text
| LH2 Text
| LH3 Text
| LItem Text
| LQuote Text
deriving (Int -> GeminiLine -> ShowS
[GeminiLine] -> ShowS
GeminiLine -> String
(Int -> GeminiLine -> ShowS)
-> (GeminiLine -> String)
-> ([GeminiLine] -> ShowS)
-> Show GeminiLine
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]
(Int -> ReadS GeminiLine)
-> ReadS [GeminiLine]
-> ReadPrec GeminiLine
-> ReadPrec [GeminiLine]
-> Read 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
(GeminiLine -> GeminiLine -> Bool)
-> (GeminiLine -> GeminiLine -> Bool) -> Eq GeminiLine
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)
decodeGemini :: Bool
-> Text
-> GeminiDocument
decodeGemini :: Bool -> Text -> [GeminiLine]
decodeGemini Bool
allowUnixStyle = [Text] -> [GeminiLine]
go ([Text] -> [GeminiLine])
-> (Text -> [Text]) -> Text -> [GeminiLine]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
allowUnixStyle then (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
T.lines else [Text] -> [Text]
forall a. a -> a
id)
([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
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) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
isPreToggle [Text]
ls
in [Text] -> GeminiLine
LPre [Text]
pres GeminiLine -> [GeminiLine] -> [GeminiLine]
forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 [Text]
rest)
| Text
"=>" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Text -> GeminiLine
parseLink Text
l GeminiLine -> [GeminiLine] -> [GeminiLine]
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) GeminiLine -> [GeminiLine] -> [GeminiLine]
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) GeminiLine -> [GeminiLine] -> [GeminiLine]
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) GeminiLine -> [GeminiLine] -> [GeminiLine]
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) GeminiLine -> [GeminiLine] -> [GeminiLine]
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) GeminiLine -> [GeminiLine] -> [GeminiLine]
forall a. a -> [a] -> [a]
: [Text] -> [GeminiLine]
go [Text]
ls
| Bool
otherwise = Text -> GeminiLine
LText Text
l GeminiLine -> [GeminiLine] -> [GeminiLine]
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 (Text -> Text) -> (Text -> Text) -> Text -> Text
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 (Maybe Text -> GeminiLine) -> Maybe Text -> GeminiLine
forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
desc' then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
desc'
where
(Text
link, Text
desc) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.stripStart Text
txt
desc' :: Text
desc' = Text -> Text
T.stripStart Text
desc
encodeGemini :: GeminiDocument -> Text
encodeGemini :: [GeminiLine] -> Text
encodeGemini = Text -> [Text] -> Text
T.intercalate Text
"\CR\LF" ([Text] -> Text)
-> ([GeminiLine] -> [Text]) -> [GeminiLine] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GeminiLine -> Text) -> [GeminiLine] -> [Text]
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
"=> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeLink Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc'
where desc' :: Text
desc' = Text -> (Text -> Text) -> Maybe Text -> Text
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" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
Text
"```" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
escapeLPre [Text]
ls [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"```"]
encodeLine (LH1 Text
t) = Text
"# " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t
encodeLine (LH2 Text
t) = Text
"## " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t
encodeLine (LH3 Text
t) = Text
"### " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t
encodeLine (LItem Text
t) = Text
"* " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t
encodeLine (LQuote Text
t) = Text
"> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNewlines Text
t
escapeCharacter :: Char
escapeCharacter :: Char
escapeCharacter = Char
' '
escapeLPre :: Text -> Text
escapeLPre :: Text -> Text
escapeLPre = Text -> Text
escapePrePrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeNewlines
escapeLText :: Text -> Text
escapeLText :: Text -> Text
escapeLText = Text -> Text
escapeAnyPrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeNewlines
escapeLink :: Text -> Text
escapeLink :: Text -> Text
escapeLink = (Char -> Char) -> Text -> Text
T.map ((Char -> Char) -> Text -> Text) -> (Char -> Char) -> Text -> Text
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 = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
t)
[ Text
"=>"
, Text
"```"
, Text
"#"
, Text
"* "
, Text
">"
]