Gemini.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Text.Gemini
-- Copyright   :  (c) Sena, 2023
-- License     :  AGPL-3.0-or-later
--
-- Maintainer  :  Sena <jn-sena@proton.me>
-- Stability   :  unstable
-- Portability :  portable
--
-- A tiny @text/gemini@ parser.
--
-- Parses Gemtext documents from and to 'Text'. See the Section 5 of the
-- [Gemini Protocol specification](https://geminiprotocol.net/docs/specification.gmi).

module Text.Gemini
  ( -- * Gemtext Types
    GemDocument
  , GemItem (..)
    -- * Decoding from Text
  , decode
  , decodeLine
    -- * Encoding to Text
  , encode
  , encodeItem
  ) where

import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import Data.Maybe (maybeToList)
import Data.Char (isSpace)
import Data.Int (Int64)
import Data.Bool (bool)


-- | A Gemtext document, in the form of an ordered list.
type GemDocument = [GemItem]

-- | A Gemtext item.
data GemItem = GemText Text -- ^ A regular Gemtext line. -- @'GemText' \<Text>@
             | GemLink Text (Maybe Text) -- ^ A Gemtext link. -- @'GemLink' \<Link> \[Optional Description]@
             | GemHeading Int64 Text -- ^ A Gemtext heading of 3 levels max. -- @'GemHeading' \<Level> \<Text>@
             | GemList [Text] -- ^ A Gemtext unordered list. -- @'GemList' \<Lines>@
             | GemQuote Text -- ^ A Gemtext quote. -- @'GemQuote' \<Text>@
             | GemPre [Text] (Maybe Text) -- ^ A Gemtext preformat. -- @'GemPre' \<Lines> [Optional Alt Text]@
             deriving (Show, Eq)


-- | Parse a @text/gemini@ file as 'GemDocument'.
-- The text should be supplied as an LF-ending 'Text'.
decode :: Text -> GemDocument
decode = parse [] . T.lines
    where -- Default line-by-line recursive parser with 'GemDocument' carried.
          -- If a list or preformatting is detected, will continue with
          -- @parseList@ and @parsePre@ respectively. Otherwise, will use
          -- 'decodeLine' on the current line only.
          parse :: GemDocument -> [Text] -> GemDocument
          parse doc (l:ls)
              | l `hasValueOf` "* " = parseList doc [value 1 l] ls
              | "```" `T.isPrefixOf` l = parsePre doc [] (optional $ value 3 l) ls
              | otherwise = parse (doc <> [decodeLine l]) ls
          parse doc [] = doc

          -- List recursive parser with a list carried. Adds the line to
          -- the list if it starts with list prefix. If the line doesn't
          -- start with the prefix, will end the recursion and continue with
          -- @parse@, with the final list added to the carried 'GemDocument'
          -- as 'GemList'.
          parseList :: GemDocument -> [Text] -> [Text] -> GemDocument
          parseList doc glist (l:ls)
              | l `hasValueOf` "* " = parseList doc (glist <> [value 1 l]) ls
              | otherwise = parse (doc <> [GemList glist]) (l:ls)
          parseList doc glist [] = doc <> [GemList glist]

          -- Preformatted recursive parser with lines carried. Adds the line to
          -- the list if the ending delimiter hasn't been reached yet. If the line
          -- is the ending with the delimiter, will end the recursion and continue
          -- with @parse@, with the final list of lines added to the carried
          -- 'GemDocument' as 'GemPre'.
          parsePre :: GemDocument -> [Text] -> Maybe Text -> [Text] -> GemDocument
          parsePre doc glines alt (l:ls)
              | "```" `T.isPrefixOf` l = parse (doc <> [GemPre glines alt]) ls
              | otherwise = parsePre doc (glines <> [l]) alt ls
          parsePre doc glines alt [] = doc <> [GemPre glines alt]

-- | Parse a /single/ @text/gemini@ line as 'GemItem'.
--
-- Notes:
--
--     * Isn't able to decode preformatted texts as they are strictly multiline.
--     * 'GemList's are also obviously singleton.
decodeLine :: Text -> GemItem
decodeLine line
    | line `hasValueOf` "=>" = let (link, desc) = T.break isSpace $ value 2 line
                                in GemLink link $ optional $ T.strip desc
    | line `hasValueOf` "#" = parseHeading line
    | line `hasValueOf` "* " = GemList [value 1 line]
    | line `hasValueOf` ">" = GemQuote $ value 1 line
    | otherwise = GemText $ T.stripEnd line
    where -- Parse a Gemtext heading.
          -- The max level of a heading is 3.
          parseHeading :: Text -> GemItem
          parseHeading l
              | T.null $ T.strip text = GemText $ T.strip l
              | otherwise = GemHeading (min (T.length pre) 3) $ T.strip text
              where (pre, text) = T.span (=='#') l


-- | Encode parsed 'GemDocument' to a @text/gemini@ file.
-- The output 'Text' uses LF-endings.
encode :: GemDocument -> Text
encode = T.unlines . foldl (\acc x -> acc <> [encodeItem x]) []

-- | Encode a /single/ parsed 'GemItem' as @text/gemini@ text.
-- The output 'Text' uses LF-endings and might be multiple lines.
--
-- /Beware/ that the final newline is always stripped, if any.
--
-- Notes:
--
--     * The text of the 'GemText' will follow a whitespace to escape the prefix
--     at the beginning if the line starts with a valid one.
--     * The link in the 'GemLink' should not have spaces.
encodeItem :: GemItem -> Text
encodeItem (GemText line) = escapePrefixes line
encodeItem (GemLink link desc) = T.unwords $ ["=>", link] <> maybeToList desc
encodeItem (GemHeading level text) = T.unwords [T.replicate (min level 3) "#", text]
encodeItem (GemList list) = T.stripEnd . T.unlines $ map (T.append "* ") list
encodeItem (GemQuote text) = T.unwords [">", text]
encodeItem (GemPre text alt) = T.stripEnd . T.unlines $ [T.concat (["```"] <> maybeToList alt)] <> text <> ["```"]

-- Escape the line prefixes by adding a whitespace at the beginning for 'GemText'.
escapePrefixes :: Text -> Text
escapePrefixes line = bool line (T.cons ' ' line) escape
    where escape = "```" `T.isPrefixOf` line ||
                   any (hasValueOf line) ["=>", "* ", ">"] ||
                   (line `hasValueOf` "#" && let (_, text) = T.span (=='#') line
                                              in not (T.null $ T.strip text))

-- @True@ if the the line has prefix /and/ a following value.
hasValueOf :: Text -> Text -> Bool
hasValueOf line prefix = prefix `T.isPrefixOf` line &&
                         not (T.null $ value (T.length prefix) line)

-- Get the value of a line.
-- Removes the prefix and strips.
value :: Int64 -> Text -> Text
value prefix = T.strip . T.drop prefix

-- @Nothing@ if the text is empty.
optional :: Text -> Maybe Text
optional text = if T.null text then Nothing else Just text