diohsc-0.1.1: TextGemini.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}

module TextGemini where

import Control.Monad.State
import Data.Maybe (catMaybes, mapMaybe)

import ANSIColour

import qualified Data.Text.Lazy as T
import URI

data Link = Link { linkUri :: URIRef, linkDescription :: T.Text }
    deriving (Eq,Ord,Show)

data GeminiLine
    = TextLine T.Text
    | LinkLine { linkLineIndex :: Int, linkLineLink :: Link }
    | AltTextLine T.Text
    | PreformatToggleLine
    | PreformattedLine T.Text
    | HeadingLine Int T.Text
    | ItemLine T.Text
    | QuoteLine T.Text
    | ErrorLine T.Text
    deriving (Eq,Ord,Show)

newtype GeminiDocument = GeminiDocument { geminiDocumentLines :: [GeminiLine] }
    deriving (Eq,Ord,Show)

extractLinks :: GeminiDocument -> [Link]
extractLinks (GeminiDocument ls) = mapMaybe linkOfLine ls
    where
    linkOfLine (LinkLine _ link) = Just link
    linkOfLine _ = Nothing

data PreOpt
    = PreOptAlt
    | PreOptPre
    | PreOptBoth
    deriving (Eq,Ord,Show)

showPreOpt :: PreOpt -> String
showPreOpt PreOptAlt = "alt"
showPreOpt PreOptPre = "pre"
showPreOpt PreOptBoth = "both"

data GemRenderOpts = GemRenderOpts
    { grOptsAnsi :: Bool
    , grOptsPre :: PreOpt
    , grOptsWrapWidth :: Int
    } deriving (Eq,Ord,Show)

printGemDoc :: GemRenderOpts -> (URIRef -> T.Text) -> GeminiDocument -> [T.Text]
printGemDoc (GemRenderOpts ansi preOpt width)
        showUri (GeminiDocument ls) = concatMap printLine ls
    where
    printLine (TextLine line) = wrap width line
    printLine (LinkLine n link) = (:[]) $
        printGemLinkLine ansi showUri (n+1) link
    printLine (AltTextLine line)
        | preOpt == PreOptPre = []
        | preOpt == PreOptBoth && T.null line = []
        | otherwise = (:[]) $ applyIf ansi withBoldStr "`` " <> line

    -- |the spec says preformat toggle lines should not be rendered, but it's the most convenient 
    -- non-disruptive way to unambiguously indicate which lines are preformatted.
    printLine PreformatToggleLine = []

    printLine (PreformattedLine line)
        | preOpt == PreOptAlt = []
        | otherwise = (:[]) $ applyIf ansi ((resetCode <>) . withBoldStr) "` " <> line
    printLine (HeadingLine level line) = (:[]) $ if ansi
            then applyIf (level /= 2) withUnderlineStr .
                applyIf (level < 3) withBoldStr $ line
            else T.take (fromIntegral level) (T.repeat '#') <> " " <> line
    printLine (ItemLine line) = wrapWith "* " "  " line
    printLine (QuoteLine line) = wrapWith "> " "> " line
    printLine (ErrorLine line) = (:[]) $ applyIf ansi (withColourStr Red)
        "! Formatting error in text/gemini: " <> line

    wrapWith first subsequent line =
        zipWith (<>) lineHeaders $ wrap (width - fromIntegral (T.length first)) line
        where lineHeaders = map (applyIf ansi withBoldStr) $ first : repeat subsequent

    wrap :: Int -> T.Text -> [T.Text]
    wrap wrapWidth line = wrap' "" 0 $ T.words line
        where
        wrap' l _ [] = [l]
        wrap' l n (w:ws) =
            let l' = if T.null l then w else l <> " " <> w
                nw = visibleLength w
                n' = n + nw + (if T.null l then 0 else 1)
            in if n' > wrapWidth
                then l : wrap' w nw ws
                else wrap' l' n' ws

printGemLinkLine :: Bool -> (URIRef -> T.Text) -> Int -> Link -> T.Text
printGemLinkLine ansi showUri n (Link uri desc) =
    applyIf ansi withBoldStr (T.pack $ '[' : show n ++ "]")
    <> " "
    <> showUri uri
    <> (if T.null desc then "" else
        applyIf ansi (withColourStr Cyan) $ " " <> desc)

data GeminiParseState = GeminiParseState { numLinks :: Int, preformatted :: Bool }

initialParseState :: GeminiParseState
initialParseState = GeminiParseState 0 False

parseGemini :: T.Text -> GeminiDocument
parseGemini text = GeminiDocument . catMaybes $ evalState
        (forM (T.lines text) (parseLine . stripTrailingCR)) initialParseState
    where
    stripTrailingCR = T.dropWhileEnd (== '\r')
    parseLine :: T.Text -> State GeminiParseState (Maybe GeminiLine)
    parseLine line = do
        pre <- gets preformatted
        if T.take 3 line == "```" then do
            modify $ \s -> s { preformatted = not pre }
            return $ if pre then case T.strip $ T.drop 3 line of
                "" -> Nothing
                _ -> Just . ErrorLine $ "Illegal non-empty text after closing '```'"
                -- ^The spec says we MUST ignore any text on a "```" line closing a preformatted 
                -- block. This seems like a gaping extensibility hole to me, so I'm interpreting it 
                -- as not disallowing an error message.
            else Just . AltTextLine . T.strip $ T.drop 3 line
        else if pre then return . Just $ PreformattedLine line
        else if T.take 2 line == "=>" then
            case parseLink . T.dropWhile isGemWhitespace $ T.drop 2 line of
                Nothing -> return . Just . ErrorLine $ "Unparseable link line: " <> line
                Just link -> do
                    n <- gets numLinks
                    modify $ \s -> s { numLinks = n + 1 }
                    return . Just $ LinkLine n link
        else let headers = T.length . T.takeWhile (== '#') $ line
            in if headers > 0 && headers < 4
            then return . Just . HeadingLine (fromIntegral headers) .
                T.dropWhile isGemWhitespace . T.dropWhile (== '#') $ line
        else if T.take 2 line == "* "
            then return . Just . ItemLine $ T.drop 2 line
        else if T.take 1 line == ">"
            then return . Just . QuoteLine $ T.drop 1 line
        else return . Just $ TextLine line

    parseLink :: T.Text -> Maybe Link
    parseLink linkInfo =
        let uriText = T.takeWhile (not . isGemWhitespace) linkInfo
            desc = T.dropWhile isGemWhitespace . T.dropWhile (not . isGemWhitespace) $ linkInfo
        in (`Link` desc) <$> parseUriReference (T.unpack uriText)

    isGemWhitespace :: Char -> Bool
    isGemWhitespace = (`elem` (" \t"::String))