Gemini.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Text.Gemini
-- Copyright   :  (c) 2024 Sena
-- License     :  LGPL-3.0-or-later
--
-- Maintainer  :  contact@sena.pink
-- Stability   :  stable
-- Portability :  portable
--
-- Parse gemtext (@text/gemini@) documents from and back into `Text'.
--
-- See the Gemini hypertext format specification at
-- <https://geminiprotocol.net/docs/gemtext-specification.gmi>.
module Text.Gemini
    ( -- * Gemtext types
      GemDocument
    , GemItem (..)

      -- * Decoding from text
    , decode
    , decodeLine

      -- * Encoding into text
    , encode
    , encodeItem

      -- * Utility functions
    , documentTitle
    ) where

import Data.Bool (bool)
import Data.Char (isSpace)
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T

-- | A gemtext document, in the form of a list of `GemItem's
type GemDocument = [GemItem]

-- | A gemtext item
data GemItem
    = -- | A regular gemtext line -- @`GemText' \<Text>@
      GemText !Text
    | -- | A gemtext link -- @`GemLink' \<Link> \[Optional Description]@
      GemLink !Text !(Maybe Text)
    | -- | A gemtext heading of 3 levels max -- @`GemHeading' \<Level> \<Text>@
      GemHeading !Int !Text
    | -- | An unordered gemtext list -- @`GemList' \<Lines>@
      --
      -- Gemtext specification does /not/ endorse grouping list items this way.
      -- This approach is purely for practical reasons, such as ease of conversion
      -- to unordered HTML lists.
      GemList ![Text]
    | -- | A gemtext quote -- @`GemQuote' \<Text>@
      GemQuote !Text
    | -- | A preformatted gemtext block -- @`GemPre' \<Lines> [Optional Alt Text]@
      GemPre ![Text] !(Maybe Text)
    deriving (Show, Eq)

-- | Parse a gemtext block as a `GemDocument'.
--
-- The input `Text' must use either CRLF or LF.
decode :: Text -> GemDocument
decode = parse . T.lines . T.replace "\CR" ""
  where
    parse :: [Text] -> GemDocument
    parse (l : ls)
        | "* " `T.isPrefixOf` l =
            let (items, rest) = span ("* " `T.isPrefixOf`) ls
             in (GemList . map (value 2) $ [l] <> items) : parse rest
        | "```" `T.isPrefixOf` l =
            let (pre, rest) = break ("```" `T.isPrefixOf`) ls
             in case rest of
                    [] -> GemText l : parse ls
                    (_ : after) -> GemPre pre (optional . value 3 $ l) : parse after
        | otherwise = decodeLine l : parse ls
    parse [] = []

-- | Parse a /single/ gemtext line as `GemItem'.
--
-- There /should not/ be any line breaks in the input; if present, they are
-- treated as spaces. Preformatted text blocks are regarded as `GemText's as they
-- are strictly multiline.
decodeLine :: Text -> GemItem
decodeLine line
    | "=>" `T.isPrefixOf` sane =
        let (link, desc) = T.break isSpace $ value 2 sane
         in if T.null link
                then GemText . T.stripEnd $ sane
                else GemLink link . optional . T.strip $ desc
    | "#" `T.isPrefixOf` sane =
        let level = min (T.length $ fst . T.span (== '#') $ sane) 3
         in GemHeading level . value level $ sane
    | "* " `T.isPrefixOf` sane = GemList [value 2 sane]
    | ">" `T.isPrefixOf` sane = GemQuote . value 1 $ sane
    | otherwise = GemText . T.stripEnd $ sane
  where
    sane = escapeLineBreaks line

-- | Encode a parsed `GemDocument' into a gemtext block.
--
-- The output `Text' uses CRLF line breaks and ends with a newline.
--
-- Empty lists are ignored completely if present. See the `encodeItem' function
-- for additional quirks.
encode :: GemDocument -> Text
encode = T.unlines . map ((<> "\CR") . encodeItem) . filter (not . empty)
  where
    empty (GemList list) = null list
    empty _ = False

-- | Encode a /single/ parsed `GemItem' into gemtext.
--
-- The output `Text' does /not/ end with an additional newline, and might be
-- multiple lines, in which case it uses CRLF line breaks.
--
-- Prefixes are escaped as necessary before encoding and the spaces in `GemLink's
-- are replaced with @%20@ to normalize them. Line breaks inside the body of an
-- item are also replaced with a space.
encodeItem :: GemItem -> Text
encodeItem item = case item of
    GemText text ->
        let shouldEscape =
                any (`T.isPrefixOf` text) ["#", "* ", ">"]
                    || "```" `T.isPrefixOf` text
                    || ("=>" `T.isPrefixOf` text && not (T.null $ value 2 text))
         in T.stripEnd . escapeLineBreaks $ bool text (T.cons ' ' text) shouldEscape
    GemLink link desc -> "=> " <> (T.replace " " "%20" . sanitize $ link) <> append desc
    GemHeading level text -> T.replicate (min level 3) "#" <> append (optional text)
    GemList list -> T.intercalate "\CR\LF" $ map (("* " <>) . sanitize) list
    GemQuote text -> ">" <> append (optional text)
    GemPre text alt -> T.intercalate "\CR\LF" $ ["```" <> append alt] <> text <> ["```"]

-- | Get the title of the `GemDocument', which is the very first `GemHeading'
-- in the document, regardless of the level of the heading.
documentTitle :: GemDocument -> Maybe Text
documentTitle doc = listToMaybe [h | GemHeading _ h <- doc]

-- `Nothing' if the text is empty.
optional :: Text -> Maybe Text
optional text = bool (Just text) Nothing $ T.null text

-- Sanitize and add a single space at the beginning if the `Text' exist,
-- otherwise return an empty `Text'.
append :: Maybe Text -> Text
append = maybe "" ((" " <>) . sanitize)

-- Strip the prefix of the line and then sanitize it to get the value.
value :: Int -> Text -> Text
value prefix = sanitize . T.drop prefix

-- Replace the line breaks with spaces and strip the `Text'.
sanitize :: Text -> Text
sanitize = T.strip . escapeLineBreaks

-- Replace the line breaks with spaces.
escapeLineBreaks :: Text -> Text
escapeLineBreaks = T.replace "\LF" " " . T.replace "\CR" ""