Gemini.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Text.Gemini
-- Copyright   :  (c) Sena, 2023
-- License     :  AGPL-3.0-or-later
--
-- Maintainer  :  Sena <jn-sena@proton.me>
-- Stability   :  stable
-- Portability :  portable
--
-- A tiny Gemtext (@text/gemini@) parser.
--
-- Parses Gemtext documents from and back 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 as Text
  , encode
  , encodeItem
  ) where

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


-- | A Gemtext document, in the form of an ordered list of 'GemItem's.
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 !Int !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 Gemtext 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. Continues with @parse@ when the line
          -- is no longer a list item, and adds the 'GemList' to the 'GemDocument'.
          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. Continues with @parse@ when the
          -- closing delimiter is reached, and adds the 'GemPre' to the 'GemDocument'.
          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/ Gemtext line as 'GemItem'.
--
-- The preformatted texts are regarded as 'GemText's as they are strictly multiline.
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' as a Gemtext file.
-- The output 'Text' uses LF-endings. Uses the 'encodeItem' function below.
--
-- Valid prefixes are escaped before encoding.
--
-- Empty lists are ignored if given.
encode :: GemDocument -> Text
encode = T.unlines . map encodeItem . filter (not . empty)
    where empty :: GemItem -> Bool
          empty (GemList list) = null list
          empty _ = False

-- | Encode a /single/ parsed 'GemItem' as Gemtext text.
-- The output 'Text' uses LF-endings and might be multiple lines.
--
-- Valid prefixes are escaped before encoding.
--
-- /Beware/ that the output text doesn't end with a newline.
--
-- The spaces in 'GemLink's are replaced with @%20@ to normalize them.
encodeItem :: GemItem -> Text
encodeItem (GemText line) = escapePrefixes line
encodeItem (GemLink link desc) = "=> " <> T.replace " " "%20" link <> maybe "" (" " <>) desc
encodeItem (GemHeading level text) = T.replicate (min level 3) "#" <> " " <> text
encodeItem (GemList list) = T.intercalate "\n" $ map ("* " <>) list
encodeItem (GemQuote text) = "> " <> text
encodeItem (GemPre text alt) = T.intercalate "\n" $ ["```" <> fromMaybe "" 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 of given length and strips.
value :: Int -> Text -> Text
value prefix = T.strip . T.drop prefix

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