From 945a755a5d2c754d2cf49f19fab22fc2f3e5ab60 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sat, 18 Apr 2020 19:24:36 +1200
Subject: [PATCH] Implement Gemini!

---
 about/version.mime~ |  0
 about/version~      |  0
 src/Input.hs        | 59 ++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 58 insertions(+), 1 deletion(-)
 delete mode 100644 about/version.mime~
 delete mode 100644 about/version~

diff --git a/about/version.mime~ b/about/version.mime~
deleted file mode 100644
index e69de29..0000000
diff --git a/about/version~ b/about/version~
deleted file mode 100644
index e69de29..0000000
diff --git a/src/Input.hs b/src/Input.hs
index 1feb41b..11a55b0 100644
--- a/src/Input.hs
+++ b/src/Input.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
 module Input(fetchDocument, docForText) where
 
 import           Data.Text.Lazy (fromStrict)
@@ -27,10 +28,14 @@ import Data.Maybe (fromMaybe)
 import Foreign.StablePtr
 import Foreign.C.String
 
+utf8' bytes = convertCharset "utf-8" $ B.toStrict bytes
+
 fetchDocument http mime uri = fetchURL' http mime uri >>= parseDocument http
 parseDocument sess (uri, "html/x-error\t", resp) = parseDocument sess (uri, "text/html", resp)
 parseDocument _ (_, "text/html", Left text) = return $ HTML.parseLT $ fromStrict text
 parseDocument _ (_, "text/html", Right bytes) = return $ HTML.parseLBS bytes
+parseDocument _ (_, "text/gemini", Left text) = return $ parseGemini text
+parseDocument _ (_, "text/gemini", Right bytes) = return $ parseGemini $ utf8' bytes
 
 parseDocument _ (_, _, Left text)
     | Right doc <- XML.parseText def $ fromStrict text = return doc
@@ -38,7 +43,7 @@ parseDocument _ (_, _, Left text)
 parseDocument _ (_, _, Right bytes) | Right doc <- XML.parseLBS def bytes = return doc
 parseDocument _ (_, 't':'e':'x':'t':'/':_, Right bytes) =
     -- charset wasn't specified, so assume utf-8.
-    return $ docForText $ convertCharset "utf-8" $ B.toStrict bytes
+    return $ docForText $ utf8' bytes
 parseDocument sess resp@(_, mime, _) = do
     dir <- getCurrentDirectory -- TODO find Downloads directory.
     ret <- saveDownload nullURI {
@@ -57,6 +62,58 @@ docForText txt = XML.Document {
         XML.documentEpilogue = []
     }
 
+--------
+---- Gemini implementation
+--------
+-- Copied from css-syntax.
+pattern (:.) :: Char -> Txt.Text -> Txt.Text
+pattern x :. xs <- (Txt.uncons -> Just (x, xs))
+
+infixr 5 :.
+
+el name text = XML.Element name M.empty [XML.NodeContent text]
+
+parseGemini :: Txt.Text -> XML.Document
+parseGemini txt = XML.Document {
+        XML.documentPrologue = XML.Prologue [] Nothing [],
+        XML.documentRoot = XML.Element {
+            XML.elementName = "body",
+            XML.elementAttributes = M.empty,
+            XML.elementNodes = map XML.NodeElement $ parseGemini' $ Txt.lines txt
+        },
+        XML.documentEpilogue = []
+    }
+
+parseGemini' :: [Txt.Text] -> [XML.Element]
+parseGemini' (('#':.'#':.'#' :. '#':.'#':.'#':.line):lines) =
+    el "h6" line : parseGemini' lines
+parseGemini' (('#':.'#':.'#' :. '#':.'#':.line):lines) =
+    el "h5" line : parseGemini' lines
+parseGemini' (('#':.'#':.'#' :. '#':.line):lines) =
+    el "h4" line : parseGemini' lines
+parseGemini' (('#':.'#':.'#':.line):lines) = el "h3" line : parseGemini' lines
+parseGemini' (('#':.'#':.line):lines) = el "h2" line : parseGemini' lines
+parseGemini' (('#':.line):lines) = el "h1" line : parseGemini' lines
+-- Not properly structured, but still sounds fine...
+parseGemini' (('*':.line):lines) = el "li" line : parseGemini' lines
+
+parseGemini' (('=':.'>':.line):lines)
+    | (url:text@(_:_)) <- Txt.words line = (el "a" $ Txt.unwords text) {
+            XML.elementAttributes = M.insert "href" url M.empty
+        } : parseGemini' lines
+    | otherwise = (el "a" $ Txt.strip line) {
+            XML.elementAttributes = M.insert "href" (Txt.strip line) M.empty
+        } : parseGemini' lines
+parseGemini' (('`':.'`':.'`':.line):lines) = go [line] lines
+    where
+        go texts ("```":lines) = el "pre" (Txt.unlines texts) : parseGemini' lines
+        go texts (('`':.'`':.'`':.line):lines) =
+            el "pre" (Txt.unlines texts) : el "p" line : parseGemini' lines
+        go texts (line:lines) = go (texts ++ [line]) lines
+        go texts [] = []
+parseGemini' (line:lines) = el "p" line : parseGemini' lines
+parseGemini' [] = []
+
 --------
 ---- C API
 --------
-- 
2.30.2