Gemini.hs

{-# LANGUAGE OverloadedStrings #-}

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

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


-- | A gemtext document, in the form of an ordered 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>@
      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 'GemDocument'.
--
-- The text should be supplied as a 'Text' which uses LF line breaks.
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'.
--
-- Preformatted text blocks 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 a parsed 'GemDocument' into a gemtext block.
--
-- The output 'Text' uses LF line breaks.
--
-- Valid prefixes are escaped before encoding. See the 'encodeItem' function below.
--
-- 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' into gemtext.
--
-- /Beware/ that the output text does /not/ end with a newline.
--
-- The output 'Text' might be multiple lines, in which case it uses LF line breaks.
--
-- Valid prefixes are escaped before encoding.
--
-- 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