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 CPP               #-}
  12 {-# LANGUAGE OverloadedStrings #-}
  13 {-# LANGUAGE Safe              #-}
  14
  15 module TextGemini where
  16
  17 import           Control.Monad       (forM)
  18 import           Control.Monad.State (State, evalState, gets, modify)
  19 import           Data.Maybe          (catMaybes, isJust, mapMaybe)
  20
  21 import           ANSIColour
  22
  23 import qualified Data.Text.Lazy      as T
  24 import           URI
  25
  26 data Link = Link { linkUri :: URIRef, linkDescription :: T.Text }
  27     deriving (Eq,Ord,Show)
  28
  29 data GeminiLine
  30     = TextLine T.Text
  31     | LinkLine { linkLineIndex :: Int, linkLineLink :: Link }
  32     | AltTextLine T.Text
  33     | PreformatToggleLine
  34     | PreformattedLine T.Text T.Text
  35     | HeadingLine Int T.Text
  36     | ItemLine T.Text
  37     | QuoteLine T.Text
  38     | ErrorLine T.Text
  39     deriving (Eq,Ord,Show)
  40
  41 newtype GeminiDocument = GeminiDocument { geminiDocumentLines :: [GeminiLine] }
  42     deriving (Eq,Ord,Show)
  43
  44 extractLinks :: GeminiDocument -> [Link]
  45 extractLinks (GeminiDocument ls) = mapMaybe linkOfLine ls
  46     where
  47     linkOfLine (LinkLine _ link) = Just link
  48     linkOfLine _                 = Nothing
  49
  50 data PreOpt
  51     = PreOptAlt
  52     | PreOptPre
  53     | PreOptBoth
  54     deriving (Eq,Ord,Show)
  55
  56 showPreOpt :: PreOpt -> String
  57 showPreOpt PreOptAlt  = "alt"
  58 showPreOpt PreOptPre  = "pre"
  59 showPreOpt PreOptBoth = "both"
  60
  61 data GemRenderOpts = GemRenderOpts
  62     { grOptsAnsi          :: Bool
  63     , grOptsPre           :: PreOpt
  64     , grOptsWrapWidth     :: Int
  65     , grOptsLinkDescFirst :: Bool
  66     } deriving (Eq,Ord,Show)
  67
  68 printGemDoc :: GemRenderOpts -> (URIRef -> T.Text) -> GeminiDocument -> [T.Text]
  69 printGemDoc (GemRenderOpts ansi preOpt width linkDescFirst)
  70         showUri (GeminiDocument doc) = concatMap printLine doc
  71     where
  72     printLine (TextLine line) = wrapWith "" False $ stripControl line
  73     printLine (AltTextLine line)
  74         | preOpt == PreOptPre || T.null line = []
  75         | otherwise = (:[]) $ applyIf ansi withBoldStr "`` " <> stripControl line
  76
  77     printLine PreformatToggleLine = []
  78
  79     printLine (PreformattedLine alt line)
  80         | preOpt == PreOptAlt && not (T.null alt) = []
  81         | otherwise =
  82             -- We allow \t and CSI escape sequences in preformatted text only
  83             let sanitise = applyIf (not ansi) (stripCSI .) sanitiseForDisplay
  84             in (:[]) $ applyIf ansi ((resetCode <>) . withBoldStr) "` " <> sanitise line
  85     printLine (HeadingLine level line) =
  86         wrapWith (T.take (fromIntegral level) (T.repeat '#') <> " ") False
  87         . applyIf ansi
  88             ( applyIf (level /= 2) withUnderlineStr
  89             . applyIf (level < 3) withBoldStr ) $ stripControl line
  90     printLine (ItemLine line) = wrapWith "* " False $ stripControl line
  91     printLine (QuoteLine line) = wrapWith "> " True $ stripControl line
  92     printLine (ErrorLine line) = (:[]) $ applyIf ansi (withColourStr Red)
  93         "! Formatting error in text/gemini: " <> line
  94     printLine (LinkLine n (Link uri desc)) =
  95         wrapWith (T.pack $ '[' : show (n+1) ++ if n+1 < 10 then "]  " else "] ") False
  96             $ (if T.null desc then id
  97                 else (if linkDescFirst then id else flip) (\a b -> a <> " " <> b)
  98                     $ applyIf ansi (withColourStr Cyan) (stripControl desc))
  99                 (showUri uri)
 100
 101     wrapWith :: T.Text -> Bool -> T.Text -> [T.Text]
 102     wrapWith pre onAll line =
 103         concat . zipWith prependHeader lineHeaders $ wrap (width - n) line
 104         where
 105             n = visibleLength pre
 106             lineHeaders = (pre:) . repeat $
 107                 if onAll then pre else T.replicate (fromIntegral n) " "
 108             splitWordHeader = if n > 0 then "|" <> T.replicate (fromIntegral n - 1) " " else ""
 109             prependHeader header (l:ls) = header <> l : ((splitWordHeader <>) <$> ls)
 110             prependHeader _ [] = []
 111
 112     wrap :: Int -> T.Text -> [[T.Text]]
 113     wrap wrapWidth line = wrap' [] "" 0 $ T.words line
 114         where
 115         maxWCWidth = 2
 116         ww = max maxWCWidth wrapWidth
 117         wrap' ls l _ [] = [ls <> [l] ]
 118         wrap' ls l n (w:ws) =
 119             let nw = visibleLength w
 120                 l' = if T.null l then w else l <> " " <> w
 121                 n' = n + nw + (if T.null l then 0 else 1)
 122             in if nw > ww && n + 1 < ww
 123                 then let (a,b) = splitAtVisible ww l'
 124                     in wrap' (ls <> [a]) "" 0 $ b:ws
 125                 else if n' > ww
 126                     then (ls <> [l]:) $ wrap' [] "" 0 $ w:ws
 127                     else wrap' ls l' n' ws
 128
 129
 130 data GeminiParseState = GeminiParseState { numLinks :: Int, preformatted :: Maybe T.Text }
 131
 132 initialParseState :: GeminiParseState
 133 initialParseState = GeminiParseState 0 Nothing
 134
 135 parseGemini :: T.Text -> GeminiDocument
 136 parseGemini text = GeminiDocument . catMaybes $ evalState
 137         (forM (T.lines text) (parseLine . stripTrailingCR)) initialParseState
 138     where
 139     stripTrailingCR = T.dropWhileEnd (== '\r')
 140     parseLine :: T.Text -> State GeminiParseState (Maybe GeminiLine)
 141     parseLine line = do
 142         pre <- gets preformatted
 143         case T.take 1 line of
 144             "`" | T.take 3 line == "```", isJust pre ->  do
 145                 modify $ \s -> s { preformatted = Nothing }
 146                 return $ case T.strip $ T.drop 3 line of
 147                     "" -> Nothing
 148                     _ -> Just . ErrorLine $ "Illegal non-empty text after closing '```'"
 149                     -- ^The spec says we MUST ignore any text on a "```" line closing a preformatted
 150                     -- block. This seems like a gaping extensibility hole to me, so I'm interpreting it
 151                     -- as not disallowing an error message.
 152             "`" | T.take 3 line == "```" ->
 153                 let alt = T.strip $ T.drop 3 line in do
 154                     modify $ \s -> s { preformatted = Just alt }
 155                     return . Just . AltTextLine $ alt
 156             _ | Just alt <- pre ->
 157                 return . Just $ PreformattedLine alt line
 158             "=" | T.take 2 line == "=>" ->
 159                 case parseLink . T.dropWhile isGemWhitespace $ T.drop 2 line of
 160                     Nothing -> return . Just . ErrorLine $ "Unparseable link line: " <> line
 161                     Just link -> do
 162                         n <- gets numLinks
 163                         modify $ \s -> s { numLinks = n + 1 }
 164                         return . Just $ LinkLine n link
 165             "#" | headers <- T.length . T.takeWhile (== '#') $ line,
 166                     headers > 0 && headers < 4 ->
 167                 return . Just . HeadingLine (fromIntegral headers) .
 168                     T.dropWhile isGemWhitespace . T.dropWhile (== '#') $ line
 169             "*" | T.take 2 line == "* " ->
 170                 return . Just . ItemLine $ T.drop 2 line
 171             ">" ->
 172                 return . Just . QuoteLine $ T.drop 1 line
 173             _ ->
 174                 return . Just $ TextLine line
 175
 176     parseLink :: T.Text -> Maybe Link
 177     parseLink linkInfo =
 178         let uriText = T.takeWhile (not . isGemWhitespace) linkInfo
 179             desc = T.dropWhile isGemWhitespace . T.dropWhile (not . isGemWhitespace) $ linkInfo
 180         in (`Link` desc) <$> parseUriReference (
 181 #ifdef IRILinks
 182         escapeIRI $
 183 #endif
 184         T.unpack uriText)
 185
 186     isGemWhitespace :: Char -> Bool
 187     isGemWhitespace = (`elem` (" \t"::String))