TextGemini.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE OverloadedStrings #-}
  12 {-# LANGUAGE Safe #-}
  13
  14 module TextGemini where
  15
  16 import Control.Monad.State
  17 import Data.Maybe (catMaybes, mapMaybe)
  18
  19 import ANSIColour
  20
  21 import qualified Data.Text.Lazy as T
  22 import URI
  23
  24 data Link = Link { linkUri :: URIRef, linkDescription :: T.Text }
  25     deriving (Eq,Ord,Show)
  26
  27 data GeminiLine
  28     = TextLine T.Text
  29     | LinkLine { linkLineIndex :: Int, linkLineLink :: Link }
  30     | AltTextLine T.Text
  31     | PreformatToggleLine
  32     | PreformattedLine T.Text
  33     | HeadingLine Int T.Text
  34     | ItemLine T.Text
  35     | QuoteLine T.Text
  36     | ErrorLine T.Text
  37     deriving (Eq,Ord,Show)
  38
  39 newtype GeminiDocument = GeminiDocument { geminiDocumentLines :: [GeminiLine] }
  40     deriving (Eq,Ord,Show)
  41
  42 extractLinks :: GeminiDocument -> [Link]
  43 extractLinks (GeminiDocument ls) = mapMaybe linkOfLine ls
  44     where
  45     linkOfLine (LinkLine _ link) = Just link
  46     linkOfLine _ = Nothing
  47
  48 data PreOpt
  49     = PreOptAlt
  50     | PreOptPre
  51     | PreOptBoth
  52     deriving (Eq,Ord,Show)
  53
  54 showPreOpt :: PreOpt -> String
  55 showPreOpt PreOptAlt = "alt"
  56 showPreOpt PreOptPre = "pre"
  57 showPreOpt PreOptBoth = "both"
  58
  59 data GemRenderOpts = GemRenderOpts
  60     { grOptsAnsi :: Bool
  61     , grOptsPre :: PreOpt
  62     , grOptsWrapWidth :: Int
  63     } deriving (Eq,Ord,Show)
  64
  65 printGemDoc :: GemRenderOpts -> (URIRef -> T.Text) -> GeminiDocument -> [T.Text]
  66 printGemDoc (GemRenderOpts ansi preOpt width)
  67         showUri (GeminiDocument ls) = concatMap printLine ls
  68     where
  69     printLine (TextLine line) = wrap width line
  70     printLine (LinkLine n link) = (:[]) $
  71         printGemLinkLine ansi showUri (n+1) link
  72     printLine (AltTextLine line)
  73         | preOpt == PreOptPre = []
  74         | preOpt == PreOptBoth && T.null line = []
  75         | otherwise = (:[]) $ applyIf ansi withBoldStr "`` " <> line
  76
  77     -- |the spec says preformat toggle lines should not be rendered, but it's the most convenient
  78     -- non-disruptive way to unambiguously indicate which lines are preformatted.
  79     printLine PreformatToggleLine = []
  80
  81     printLine (PreformattedLine line)
  82         | preOpt == PreOptAlt = []
  83         | otherwise = (:[]) $ applyIf ansi ((resetCode <>) . withBoldStr) "` " <> line
  84     printLine (HeadingLine level line) = (:[]) $ if ansi
  85             then applyIf (level /= 2) withUnderlineStr .
  86                 applyIf (level < 3) withBoldStr $ line
  87             else T.take (fromIntegral level) (T.repeat '#') <> " " <> line
  88     printLine (ItemLine line) = wrapWith "* " "  " line
  89     printLine (QuoteLine line) = wrapWith "> " "> " line
  90     printLine (ErrorLine line) = (:[]) $ applyIf ansi (withColourStr Red)
  91         "! Formatting error in text/gemini: " <> line
  92
  93     wrapWith first subsequent line =
  94         zipWith (<>) lineHeaders $ wrap (width - fromIntegral (T.length first)) line
  95         where lineHeaders = map (applyIf ansi withBoldStr) $ first : repeat subsequent
  96
  97     wrap :: Int -> T.Text -> [T.Text]
  98     wrap wrapWidth line = wrap' "" 0 $ T.words line
  99         where
 100         wrap' l _ [] = [l]
 101         wrap' l n (w:ws) =
 102             let l' = if T.null l then w else l <> " " <> w
 103                 nw = fromIntegral . T.length $ stripANSI w
 104                 n' = n + nw + (if T.null l then 0 else 1)
 105             in if n' > wrapWidth
 106                 then l : wrap' w nw ws
 107                 else wrap' l' n' ws
 108
 109 printGemLinkLine :: Bool -> (URIRef -> T.Text) -> Int -> Link -> T.Text
 110 printGemLinkLine ansi showUri n (Link uri desc) =
 111     applyIf ansi withBoldStr (T.pack $ '[' : show n ++ "]")
 112     <> " "
 113     <> showUri uri
 114     <> (if T.null desc then "" else
 115         applyIf ansi (withColourStr Cyan) $ " " <> desc)
 116
 117 data GeminiParseState = GeminiParseState { numLinks :: Int, preformatted :: Bool }
 118
 119 initialParseState :: GeminiParseState
 120 initialParseState = GeminiParseState 0 False
 121
 122 parseGemini :: T.Text -> GeminiDocument
 123 parseGemini text = GeminiDocument . catMaybes $ evalState
 124         (forM (T.lines text) (parseLine . stripTrailingCR)) initialParseState
 125     where
 126     stripTrailingCR = T.dropWhileEnd (== '\r')
 127     parseLine :: T.Text -> State GeminiParseState (Maybe GeminiLine)
 128     parseLine line = do
 129         pre <- gets preformatted
 130         if T.take 3 line == "```" then do
 131             modify $ \s -> s { preformatted = not pre }
 132             return $ if pre then case T.strip $ T.drop 3 line of
 133                 "" -> Nothing
 134                 _ -> Just . ErrorLine $ "Illegal non-empty text after closing '```'"
 135                 -- ^The spec says we MUST ignore any text on a "```" line closing a preformatted
 136                 -- block. This seems like a gaping extensibility hole to me, so I'm interpreting it
 137                 -- as not disallowing an error message.
 138             else Just . AltTextLine . T.strip $ T.drop 3 line
 139         else if pre then return . Just $ PreformattedLine line
 140         else if T.take 2 line == "=>" then
 141             case parseLink . T.dropWhile isGemWhitespace $ T.drop 2 line of
 142                 Nothing -> return . Just . ErrorLine $ "Unparseable link line: " <> line
 143                 Just link -> do
 144                     n <- gets numLinks
 145                     modify $ \s -> s { numLinks = n + 1 }
 146                     return . Just $ LinkLine n link
 147         else let headers = T.length . T.takeWhile (== '#') $ line
 148             in if headers > 0 && headers < 4
 149             then return . Just . HeadingLine (fromIntegral headers) .
 150                 T.dropWhile isGemWhitespace . T.dropWhile (== '#') $ line
 151         else if T.take 2 line == "* "
 152             then return . Just . ItemLine $ T.drop 2 line
 153         else if T.take 1 line == ">"
 154             then return . Just . QuoteLine $ T.drop 1 line
 155         else return . Just $ TextLine line
 156
 157     parseLink :: T.Text -> Maybe Link
 158     parseLink linkInfo =
 159         let uriText = T.takeWhile (not . isGemWhitespace) linkInfo
 160             desc = T.dropWhile isGemWhitespace . T.dropWhile (not . isGemWhitespace) $ linkInfo
 161         in (`Link` desc) <$> parseUriReference (T.unpack uriText)
 162
 163     isGemWhitespace :: Char -> Bool
 164     isGemWhitespace = (`elem` (" \t"::String))