{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
module Network.URI.Fetch.XML(Page(..), loadVisited,
    fetchDocument, pageForText, applyCSScharset, readStrict) where

import           Data.Text.Lazy (fromStrict)
import qualified Data.Text as Txt
import           Data.Text (Text)
import qualified Data.Text.IO as Txt
import           Data.Text.Encoding
import qualified Data.Text.Lazy as LTxt
import qualified Data.ByteString.Lazy as B
import qualified Text.HTML.DOM as HTML
import qualified Text.XML as XML
import           Text.XML (Document(..))
import           Network.URI
import           Network.URI.Fetch
import           Network.URI.Charset
import qualified Data.Map as M
import qualified Data.Set as Set
import           Data.Set (Set(..))
import           Data.List (intercalate)
import           Data.Time.Clock

-- For alternative styles
import qualified Data.CSS.Syntax.Tokens as CSSTok
import Stylist.Parse

import System.IO
import System.IO.Temp
import Data.Default.Class
import System.Directory
import System.FilePath ((</>))
import Data.FileEmbed
import Data.Maybe (fromMaybe)
import Text.Read (readMaybe)

import Network.URI.Fetch.XML.Table -- Apply table sorting here...
import Data.HTML2CSS (html2css)

data Page styles = Page {
    forall styles. Page styles -> URI
pageURL :: URI,
    forall styles. Page styles -> styles
css :: styles,
    forall styles. Page styles -> URI -> String -> styles
initCSS :: URI -> String -> styles,
    forall styles. Page styles -> String
domain :: String,
    forall styles. Page styles -> Document
html :: Document,
    forall styles. Page styles -> String
pageTitle :: String,
    forall styles. Page styles -> String
pageMIME :: String,
    forall styles. Page styles -> [Application]
apps :: [Application],
    forall styles. Page styles -> [(String, URI)]
backStack :: [(String, URI)],
    forall styles. Page styles -> [(String, URI)]
forwardStack :: [(String, URI)],
    -- Probably don't need an MVar here, but let's be safe!
    forall styles. Page styles -> Set Text
visitedURLs :: Set Text,
    forall styles. Page styles -> String
appName :: String
}

loadVisited :: String -> IO (Set Text)
loadVisited :: String -> IO (Set Text)
loadVisited String
appname = do
    String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
appname
    let path :: String
path = String
dir String -> String -> String
</> String
"history.gmni"
    Bool
exists <- String -> IO Bool
doesFileExist String
path

    if Bool
exists then do
        String
file <- String -> IO String
readStrict String
path
        let hist :: Set Text
hist = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [String -> Text
Txt.pack String
uri | String
_:String
uri:[String]
_ <- (String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words ([String] -> [[String]]) -> [String] -> [[String]]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
file]
        Set Text -> IO (Set Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Set Text
hist
    else Set Text -> IO (Set Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Set Text
forall a. Set a
Set.empty

readStrict :: String -> IO String
readStrict String
path = do String
s <- String -> IO String
Prelude.readFile String
path; String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> IO String -> IO String
`seq` String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s

utf8' :: ByteString -> Text
utf8' ByteString
bytes = String -> ByteString -> Text
convertCharset String
"utf-8" (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.toStrict ByteString
bytes
aCCEPT :: [String]
aCCEPT = [String
"text/xml", String
"application/xml", String
"text/html", String
"text/gemini",
    String
"text/csv", String
"text/tab-separated-values", String
"text/css", String
"text/*", String
"*/*"]

fetchDocument :: Session -> Page styles -> URI -> IO (Page styles)
fetchDocument Session
http Page styles
referer URI { uriScheme :: URI -> String
uriScheme = String
"action:", uriPath :: URI -> String
uriPath = String
"nocache" } =
    Session -> Page styles -> URI -> IO (Page styles)
fetchDocument Session
http { cachingEnabled :: Bool
cachingEnabled = Bool
False } Page styles
referer (URI -> IO (Page styles)) -> URI -> IO (Page styles)
forall a b. (a -> b) -> a -> b
$ Page styles -> URI
forall styles. Page styles -> URI
pageURL Page styles
referer
fetchDocument Session
http Page styles
referer URI { uriScheme :: URI -> String
uriScheme = String
"action:", uriPath :: URI -> String
uriPath = String
"novalidate" } =
    Session -> Page styles -> URI -> IO (Page styles)
fetchDocument Session
http { validateCertificates :: Bool
validateCertificates = Bool
False } Page styles
referer (URI -> IO (Page styles)) -> URI -> IO (Page styles)
forall a b. (a -> b) -> a -> b
$ Page styles -> URI
forall styles. Page styles -> URI
pageURL Page styles
referer
fetchDocument Session
http Page styles
referer URI { uriScheme :: URI -> String
uriScheme = String
"action:", uriPath :: URI -> String
uriPath = String
"history/back" } =
        Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
http [String]
aCCEPT (Page styles -> URI
forall styles. Page styles -> URI
pageURL Page styles
referer') IO (URI, String, Either Text ByteString)
-> ((URI, String, Either Text ByteString) -> IO (Page styles))
-> IO (Page styles)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Page styles
-> Session
-> Bool
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
forall {styles}.
StyleSheet styles =>
Page styles
-> Session
-> Bool
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
parseDocument' Page styles
referer' Session
http Bool
False
    where referer' :: Page styles
referer' = Page styles -> Integer -> Page styles
forall style. Page style -> Integer -> Page style
shiftHistory Page styles
referer (-Integer
1)
fetchDocument Session
http Page styles
referer URI { uriScheme :: URI -> String
uriScheme = String
"action:", uriPath :: URI -> String
uriPath = String
"history/forward" } =
        Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
http [String]
aCCEPT (Page styles -> URI
forall styles. Page styles -> URI
pageURL Page styles
referer') IO (URI, String, Either Text ByteString)
-> ((URI, String, Either Text ByteString) -> IO (Page styles))
-> IO (Page styles)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Page styles
-> Session
-> Bool
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
forall {styles}.
StyleSheet styles =>
Page styles
-> Session
-> Bool
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
parseDocument' Page styles
referer' Session
http Bool
False
    where referer' :: Page styles
referer' = Page styles -> Integer -> Page styles
forall style. Page style -> Integer -> Page style
shiftHistory Page styles
referer Integer
1
fetchDocument Session
http Page styles
referer URI {
        uriScheme :: URI -> String
uriScheme = String
"action:", uriPath :: URI -> String
uriPath = Char
'h':Char
'i':Char
's':Char
't':Char
'o':Char
'r':Char
'y':Char
'/':String
x
    } | Just Integer
x' <- String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe String
x, Page styles
referer' <- Page styles -> Integer -> Page styles
forall style. Page style -> Integer -> Page style
shiftHistory Page styles
referer Integer
x' =
        Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
http [String]
aCCEPT (Page styles -> URI
forall styles. Page styles -> URI
pageURL Page styles
referer') IO (URI, String, Either Text ByteString)
-> ((URI, String, Either Text ByteString) -> IO (Page styles))
-> IO (Page styles)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Page styles
-> Session
-> Bool
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
forall {styles}.
StyleSheet styles =>
Page styles
-> Session
-> Bool
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
parseDocument' Page styles
referer Session
http Bool
False
fetchDocument Session
http Page styles
referer URI { uriScheme :: URI -> String
uriScheme = String
"app:", uriPath :: URI -> String
uriPath = String
appID } = do
    Session -> Application -> String -> URI -> IO Bool
dispatchByApp Session
http Application :: String -> URI -> String -> String -> Application
Application {
        name :: String
name = String
"", icon :: URI
icon = URI
nullURI, description :: String
description = String
"",
        appId :: String
appId = String
appID
      } (Page styles -> String
forall styles. Page styles -> String
pageMIME Page styles
referer) (URI -> IO Bool) -> URI -> IO Bool
forall a b. (a -> b) -> a -> b
$ Page styles -> URI
forall styles. Page styles -> URI
pageURL Page styles
referer
    Page styles -> IO (Page styles)
forall (m :: * -> *) a. Monad m => a -> m a
return Page styles
referer -- TODO play an error or success sound
fetchDocument Session
http referer :: Page styles
referer@Page { pageURL :: forall styles. Page styles -> URI
pageURL = URI
uri0 } uri :: URI
uri@URI { uriFragment :: URI -> String
uriFragment = String
anchor }
    | URI
uri { uriFragment :: String
uriFragment = String
"" } URI -> URI -> Bool
forall a. Eq a => a -> a -> Bool
== URI
uri0 { uriFragment :: String
uriFragment = String
"" } = Page styles -> IO (Page styles)
forall (m :: * -> *) a. Monad m => a -> m a
return Page styles
referer {
        html :: Document
html = String -> Document -> Document
applySortDoc String
anchor (Document -> Document) -> Document -> Document
forall a b. (a -> b) -> a -> b
$ Page styles -> Document
forall styles. Page styles -> Document
html Page styles
referer,
        pageURL :: URI
pageURL = URI
uri
    }
fetchDocument Session
http Page styles
referer URI
uri = Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
http [String]
aCCEPT URI
uri IO (URI, String, Either Text ByteString)
-> ((URI, String, Either Text ByteString) -> IO (Page styles))
-> IO (Page styles)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Page styles
-> Session
-> Bool
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
forall {styles}.
StyleSheet styles =>
Page styles
-> Session
-> Bool
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
parseDocument' Page styles
referer Session
http Bool
True

shiftHistory :: Page style -> Integer -> Page style
shiftHistory :: forall style. Page style -> Integer -> Page style
shiftHistory Page style
self Integer
0 = Page style
self
shiftHistory self :: Page style
self@Page { backStack :: forall styles. Page styles -> [(String, URI)]
backStack = (String
title, URI
url):[(String, URI)]
bs } Integer
delta | Integer
delta Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 =
    Page style -> Integer -> Page style
forall style. Page style -> Integer -> Page style
shiftHistory Page style
self {
        backStack :: [(String, URI)]
backStack = [(String, URI)]
bs,
        forwardStack :: [(String, URI)]
forwardStack = (Page style -> String
forall styles. Page styles -> String
pageTitle Page style
self, Page style -> URI
forall styles. Page styles -> URI
pageURL Page style
self)(String, URI) -> [(String, URI)] -> [(String, URI)]
forall a. a -> [a] -> [a]
:Page style -> [(String, URI)]
forall styles. Page styles -> [(String, URI)]
forwardStack Page style
self,
        pageTitle :: String
pageTitle = String
title,
        pageURL :: URI
pageURL = URI
url
    } (Integer -> Page style) -> Integer -> Page style
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Enum a => a -> a
succ Integer
delta
shiftHistory self :: Page style
self@Page { forwardStack :: forall styles. Page styles -> [(String, URI)]
forwardStack = (String
title, URI
url):[(String, URI)]
fs } Integer
delta | Integer
delta Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 =
    Page style -> Integer -> Page style
forall style. Page style -> Integer -> Page style
shiftHistory Page style
self {
        forwardStack :: [(String, URI)]
forwardStack = [(String, URI)]
fs,
        backStack :: [(String, URI)]
backStack = (Page style -> String
forall styles. Page styles -> String
pageTitle Page style
self, Page style -> URI
forall styles. Page styles -> URI
pageURL Page style
self)(String, URI) -> [(String, URI)] -> [(String, URI)]
forall a. a -> [a] -> [a]
:Page style -> [(String, URI)]
forall styles. Page styles -> [(String, URI)]
backStack Page style
self,
        pageTitle :: String
pageTitle = String
title,
        pageURL :: URI
pageURL = URI
url
    } (Integer -> Page style) -> Integer -> Page style
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Enum a => a -> a
pred Integer
delta
shiftHistory Page style
self Integer
_ = Page style
self -- Error case.

parseDocument' :: Page styles
-> Session
-> Bool
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
parseDocument' ref :: Page styles
ref@Page {visitedURLs :: forall styles. Page styles -> Set Text
visitedURLs = Set Text
hist} Session
sess Bool
saveHist resp :: (URI, String, Either Text ByteString)
resp@(URI {uriFragment :: URI -> String
uriFragment = String
anch}, String
mime, Either Text ByteString
_) = do
    Page styles
page <- Page styles
-> Session
-> (URI, String, Either Text ByteString)
-> IO (Page styles)
forall s.
StyleSheet s =>
Page s
-> Session -> (URI, String, Either Text ByteString) -> IO (Page s)
parseDocument Page styles
ref {domain :: String
domain = String
"document"} Session
sess (URI, String, Either Text ByteString)
resp IO (Page styles)
-> (Page styles -> IO (Page styles)) -> IO (Page styles)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Set Text -> Page styles -> IO (Page styles)
forall {styles}. Set Text -> Page styles -> IO (Page styles)
logHistory Set Text
hist
    [Application]
apps' <- Session -> String -> IO [Application]
appsForMIME Session
sess String
mime
    Page styles -> IO (Page styles)
forall (m :: * -> *) a. Monad m => a -> m a
return (Page styles -> IO (Page styles))
-> Page styles -> IO (Page styles)
forall a b. (a -> b) -> a -> b
$ Page styles -> Page styles
forall {styles}. Page styles -> Page styles
attachHistory Page styles
page {
        pageMIME :: String
pageMIME = String
mime,
        apps :: [Application]
apps = [Application]
apps',
        html :: Document
html = String -> Document -> Document
applySortDoc String
anch (Document -> Document) -> Document -> Document
forall a b. (a -> b) -> a -> b
$ Page styles -> Document
forall styles. Page styles -> Document
html Page styles
page
    }
  where
    attachHistory :: Page styles -> Page styles
attachHistory x :: Page styles
x@Page { pageTitle :: forall styles. Page styles -> String
pageTitle = String
title, pageURL :: forall styles. Page styles -> URI
pageURL = URI
url }
        | Bool
saveHist = Page styles
x { backStack :: [(String, URI)]
backStack = (String
title, URI
url)(String, URI) -> [(String, URI)] -> [(String, URI)]
forall a. a -> [a] -> [a]
:Page styles -> [(String, URI)]
forall styles. Page styles -> [(String, URI)]
backStack Page styles
ref, forwardStack :: [(String, URI)]
forwardStack = Page styles -> [(String, URI)]
forall styles. Page styles -> [(String, URI)]
forwardStack Page styles
ref }
        | Bool
otherwise = Page styles
x
parseDocument :: StyleSheet s => Page s -> Session -> (URI, String, Either Text B.ByteString)
        -> IO (Page s)
parseDocument :: forall s.
StyleSheet s =>
Page s
-> Session -> (URI, String, Either Text ByteString) -> IO (Page s)
parseDocument Page s
ref Session
sess (URI
uri, String
"html/x-error\t", Either Text ByteString
resp) =
    Page s
-> Session -> (URI, String, Either Text ByteString) -> IO (Page s)
forall s.
StyleSheet s =>
Page s
-> Session -> (URI, String, Either Text ByteString) -> IO (Page s)
parseDocument Page s
ref { domain :: String
domain = String
"error" } Session
sess (URI
uri, String
"text/html", Either Text ByteString
resp)
parseDocument Page s
p Session
_ (URI
uri, String
"text/html", Left Text
text) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
p URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Text -> Document
HTML.parseLT (Text -> Document) -> Text -> Document
forall a b. (a -> b) -> a -> b
$ Text -> Text
fromStrict Text
text
parseDocument Page s
p Session
_(URI
uri, String
"text/html", Right ByteString
bytes) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
p URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ ByteString -> Document
HTML.parseLBS ByteString
bytes
parseDocument Page s
p Session
_
        (URI
uri, Char
't':Char
'e':Char
'x':Char
't':Char
'/':Char
'g':Char
'e':Char
'm':Char
'i':Char
'n':Char
'i':Char
';':Char
'l':Char
'a':Char
'n':Char
'g':Char
'=':String
lang, Left Text
text) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
p URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Maybe String -> Text -> Document
parseGemini (String -> Maybe String
forall a. a -> Maybe a
Just String
lang) Text
text
parseDocument Page s
p Session
_
        (URI
uri, Char
't':Char
'e':Char
'x':Char
't':Char
'/':Char
'g':Char
'e':Char
'm':Char
'i':Char
'n':Char
'i':Char
';':Char
'l':Char
'a':Char
'n':Char
'g':Char
'=':String
lang, Right ByteString
bytes) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
p URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Maybe String -> Text -> Document
parseGemini (String -> Maybe String
forall a. a -> Maybe a
Just String
lang) (Text -> Document) -> Text -> Document
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
utf8' ByteString
bytes
parseDocument Page s
p Session
_ (URI
uri, String
"text/gemini", Left Text
text) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
p URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Maybe String -> Text -> Document
parseGemini Maybe String
forall a. Maybe a
Nothing Text
text
parseDocument Page s
p Session
_ (URI
uri, String
"text/gemini", Right ByteString
bytes) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
p URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Maybe String -> Text -> Document
parseGemini Maybe String
forall a. Maybe a
Nothing (Text -> Document) -> Text -> Document
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
utf8' ByteString
bytes
parseDocument Page s
a Session
b (URI
a', b' :: String
b'@String
"text/css", Right ByteString
bytes) =
    Page s
-> Session -> (URI, String, Either Text ByteString) -> IO (Page s)
forall s.
StyleSheet s =>
Page s
-> Session -> (URI, String, Either Text ByteString) -> IO (Page s)
parseDocument Page s
a Session
b (URI
a', String
b', Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> ByteString -> Text
applyCSScharset ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Txt.unpack [Text]
charsets) (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.toStrict ByteString
bytes)
parseDocument referer :: Page s
referer@Page {pageURL :: forall styles. Page styles -> URI
pageURL = URI
uri', initCSS :: forall styles. Page styles -> URI -> String -> styles
initCSS = URI -> String -> s
css', appName :: forall styles. Page styles -> String
appName = String
name} Session
_
    (URI
uri, String
"text/css", Left Text
text)
  | URI {uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just URIAuth
host} <- Page s -> URI
forall styles. Page styles -> URI
pageURL Page s
referer = do
    -- Save this per-domain setting
    String
dir <- (String -> String -> String
</> String
"domain") (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig String
name
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
    String -> Text -> IO ()
Txt.writeFile (String
dir String -> String -> String
</> URIAuth -> String
uriRegName URIAuth
host) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Token] -> Text
CSSTok.serialize ([Token] -> Text) -> [Token] -> Text
forall a b. (a -> b) -> a -> b
$ (Token -> Token) -> [Token] -> [Token]
forall a b. (a -> b) -> [a] -> [b]
map Token -> Token
absolutizeCSS ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> [Token]
CSSTok.tokenize Text
text

    Page s -> IO (Page s)
forall (m :: * -> *) a. Monad m => a -> m a
return Page s
ret
  | Bool
otherwise = Page s -> IO (Page s)
forall (m :: * -> *) a. Monad m => a -> m a
return Page s
ret
 where
  ret :: Page s
ret = Page s
referer {
        css :: s
css = s -> URI -> Text -> s
forall s. StyleSheet s => s -> URI -> Text -> s
parseForURL (URI -> String -> s
css' URI
uri' String
"document") URI
uri Text
text
    }
  absolutizeCSS :: Token -> Token
absolutizeCSS (CSSTok.Url Text
text) | Just URI
rel <- String -> Maybe URI
parseRelativeReference (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
text =
    Text -> Token
CSSTok.Url (Text -> Token) -> Text -> Token
forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToStr' (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ URI -> URI -> URI
relativeTo URI
rel URI
uri'
  absolutizeCSS Token
tok = Token
tok
parseDocument Page s
ref Session
_ (URI
uri, String
"text/csv", Left Text
body) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
ref URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Document
parseDelimitedToTable Char
',' Text
body
parseDocument Page s
ref Session
_ (URI
uri, String
"text/tab-separated-values", Left Text
body) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
ref URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Document
parseDelimitedToTable Char
'\t' Text
body
parseDocument Page s
ref Session
_ (URI
uri, String
"text/csv", Right ByteString
body) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
ref URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Document
parseDelimitedToTable Char
',' (Text -> Document) -> Text -> Document
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
utf8' ByteString
body
parseDocument Page s
ref Session
_ (URI
uri, String
"text/tab-separated-values", Right ByteString
body) =
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
ref URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Document
parseDelimitedToTable Char
'\t' (Text -> Document) -> Text -> Document
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
utf8' ByteString
body

parseDocument Page s
ref Session
sess (URI
uri, String
mime, Either Text ByteString
body) | String
mime' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
mime = Page s
-> Session -> (URI, String, Either Text ByteString) -> IO (Page s)
forall s.
StyleSheet s =>
Page s
-> Session -> (URI, String, Either Text ByteString) -> IO (Page s)
parseDocument Page s
ref Session
sess (URI
uri, String
mime', Either Text ByteString
body)
    where mime' :: String
mime' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';') String
mime
parseDocument Page s
p Session
_ (URI
uri, String
_, Left Text
text)
    | Right Document
doc <- ParseSettings -> Text -> Either SomeException Document
XML.parseText ParseSettings
forall a. Default a => a
def (Text -> Either SomeException Document)
-> Text -> Either SomeException Document
forall a b. (a -> b) -> a -> b
$ Text -> Text
fromStrict Text
text = Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
p URI
uri Document
doc
    | Bool
otherwise = Page s -> URI -> Text -> IO (Page s)
forall {s}. StyleSheet s => Page s -> URI -> Text -> IO (Page s)
pageForText Page s
p URI
uri Text
text
parseDocument Page s
p Session
_ (URI
uri, String
_, Right ByteString
bytes)
    | Right Document
doc <- ParseSettings -> ByteString -> Either SomeException Document
XML.parseLBS ParseSettings
forall a. Default a => a
def ByteString
bytes = Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
p URI
uri Document
doc
parseDocument Page s
p Session
_ (URI
uri, Char
't':Char
'e':Char
'x':Char
't':Char
'/':String
_, Right ByteString
bytes) =
    -- charset wasn't specified, so assume utf-8.
    Page s -> URI -> Text -> IO (Page s)
forall {s}. StyleSheet s => Page s -> URI -> Text -> IO (Page s)
pageForText Page s
p URI
uri (Text -> IO (Page s)) -> Text -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
utf8' ByteString
bytes
parseDocument Page s
p Session
sess resp :: (URI, String, Either Text ByteString)
resp@(URI
uri, String
mime, Either Text ByteString
_) = do
    String
dir <- IO String
getCurrentDirectory -- TODO find Downloads directory.
    Maybe String
ret <- URI -> String -> (URI, String, Either Text ByteString) -> IO URI
saveDownload URI
nullURI {
        uriScheme :: String
uriScheme = String
"file:",
        uriAuthority :: Maybe URIAuth
uriAuthority = URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (String -> String -> String -> URIAuth
URIAuth String
"" String
"" String
"")
    } String
dir (URI, String, Either Text ByteString)
resp IO URI -> (URI -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Session -> String -> URI -> IO (Maybe String)
dispatchByMIME Session
sess String
mime
    Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
p URI
uri (Document -> IO (Page s)) -> Document -> IO (Page s)
forall a b. (a -> b) -> a -> b
$ Text -> Document
HTML.parseLT (Text -> Document) -> Text -> Document
forall a b. (a -> b) -> a -> b
$ String -> Text
LTxt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Unsupported filetype" Maybe String
ret

pageForText :: Page s -> URI -> Text -> IO (Page s)
pageForText Page s
referer URI
uri Text
txt = Page s -> URI -> Document -> IO (Page s)
forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc Page s
referer URI
uri Document :: Prologue -> Element -> [Miscellaneous] -> Document
XML.Document {
        documentPrologue :: Prologue
XML.documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] Maybe Doctype
forall a. Maybe a
Nothing [],
        documentRoot :: Element
XML.documentRoot = Element :: Name -> Map Name Text -> [Node] -> Element
XML.Element {
            elementName :: Name
XML.elementName = Name
"pre",
            elementAttributes :: Map Name Text
XML.elementAttributes = Map Name Text
forall k a. Map k a
M.empty,
            elementNodes :: [Node]
XML.elementNodes = [Text -> Node
XML.NodeContent Text
txt]
        },
        documentEpilogue :: [Miscellaneous]
XML.documentEpilogue = []
    }

pageForDoc :: StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc :: forall s. StyleSheet s => Page s -> URI -> Document -> IO (Page s)
pageForDoc referer :: Page s
referer@Page {initCSS :: forall styles. Page styles -> URI -> String -> styles
initCSS = URI -> String -> s
css', appName :: forall styles. Page styles -> String
appName = String
appname, domain :: forall styles. Page styles -> String
domain = String
d} URI
uri Document
doc = do
    -- See if the user has configured an alternate stylesheet for this domain.
    let authorStyle :: IO s
authorStyle = s -> IO s
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> IO s) -> s -> IO s
forall a b. (a -> b) -> a -> b
$ Document -> URI -> s -> s
forall s. StyleSheet s => Document -> URI -> s -> s
html2css Document
doc URI
uri (s -> s) -> s -> s
forall a b. (a -> b) -> a -> b
$ URI -> String -> s
css' URI
uri String
d
    s
styles <- case URI -> Maybe URIAuth
uriAuthority URI
uri of
        Maybe URIAuth
Nothing -> IO s
authorStyle
        Just URIAuth
host -> do
            String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig String
appname
            let path :: String
path = String
dir String -> String -> String
</> String
"domain" String -> String -> String
</> URIAuth -> String
uriRegName URIAuth
host
            Bool
hasAltStyle <- String -> IO Bool
doesFileExist String
path
            if Bool -> Bool
not Bool
hasAltStyle then IO s
authorStyle else s -> Text -> s
forall s. StyleSheet s => s -> Text -> s
parse (URI -> String -> s
css' URI
uri String
d) (Text -> s) -> IO Text -> IO s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
Txt.readFile String
path

    Page s -> IO (Page s)
forall (m :: * -> *) a. Monad m => a -> m a
return Page s
referer {pageURL :: URI
pageURL = URI
uri, html :: Document
html = Document
doc, css :: s
css = s
styles}

logHistory :: Set Text -> Page styles -> IO (Page styles)
logHistory Set Text
hist ret :: Page styles
ret@Page {pageURL :: forall styles. Page styles -> URI
pageURL = URI
url', html :: forall styles. Page styles -> Document
html = Document
doc, appName :: forall styles. Page styles -> String
appName = String
name} = do
    String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
name
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
    UTCTime
now <- IO UTCTime
getCurrentTime
    let title :: String
title = Text -> String
Txt.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Element -> Text
getTitle (Element -> Text) -> Element -> Text
forall a b. (a -> b) -> a -> b
$ Document -> Element
XML.documentRoot Document
doc
    String -> String -> IO ()
appendFile (String
dir String -> String -> String
</> String
"history.gmni") (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " [
        String
"=>", URI -> String
uriToStr' URI
url', UTCTime -> String
forall a. Show a => a -> String
show UTCTime
now, String
title
      ]

    Page styles -> IO (Page styles)
forall (m :: * -> *) a. Monad m => a -> m a
return Page styles
ret { pageTitle :: String
pageTitle = String
title, visitedURLs :: Set Text
visitedURLs = Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert (String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToStr' URI
url') Set Text
hist}
  where
    getTitle :: Element -> Text
getTitle (XML.Element Name
"title" Map Name Text
_ [Node]
childs) = [Text] -> Text
Txt.concat [Text
txt | XML.NodeContent Text
txt <- [Node]
childs]
    getTitle (XML.Element Name
"h1" Map Name Text
_ [Node]
childs) = [Text] -> Text
Txt.concat [Text
txt | XML.NodeContent Text
txt <- [Node]
childs]
    getTitle (XML.Element Name
_ Map Name Text
_ [Node]
childs)
        | Text
title:[Text]
_ <- [Element -> Text
getTitle Element
el | XML.NodeElement Element
el <- [Node]
childs] = Text
title
        | Bool
otherwise = Text
""

uriToStr' :: URI -> String
uriToStr' :: URI -> String
uriToStr' URI
uri = (String -> String) -> URI -> String -> String
uriToString String -> String
forall a. a -> a
id URI
uri String
""

--------
---- CSS charset sniffing
--------
applyCSScharset :: [String] -> ByteString -> Text
applyCSScharset (String
charset:[String]
charsets) ByteString
bytes
        | [Token] -> Text
cssCharset (Text -> [Token]
CSSTok.tokenize Text
text) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
Txt.pack String
charset = Text
text
        | Bool
otherwise = [String] -> ByteString -> Text
applyCSScharset [String]
charsets ByteString
bytes
    where
        text :: Text
text = String -> ByteString -> Text
convertCharset String
charset ByteString
bytes
applyCSScharset [String]
_ ByteString
bytes = String -> ByteString -> Text
convertCharset String
"utf-8" ByteString
bytes
cssCharset :: [Token] -> Text
cssCharset [Token]
toks | (CSSTok.AtKeyword Text
"charset":[Token]
toks') <- [Token] -> [Token]
skipCSSspace [Token]
toks,
        (CSSTok.String Text
charset:[Token]
_) <- [Token] -> [Token]
skipCSSspace [Token]
toks' = Text
charset
    | Bool
otherwise = Text
""
skipCSSspace :: [Token] -> [Token]
skipCSSspace (Token
CSSTok.Whitespace:[Token]
toks) = [Token] -> [Token]
skipCSSspace [Token]
toks
skipCSSspace [Token]
toks = [Token]
toks

--------
---- Gemini implementation
--------
-- Copied from css-syntax.
pattern (:.) :: Char -> Txt.Text -> Txt.Text
pattern x $m:. :: forall {r}. Text -> (Char -> Text -> r) -> (Void# -> r) -> r
:. xs <- (Txt.uncons -> Just (x, xs))

infixr 5 :.

el :: Name -> Text -> Element
el Name
name Text
text = Name -> Map Name Text -> [Node] -> Element
XML.Element Name
name Map Name Text
forall k a. Map k a
M.empty [Text -> Node
XML.NodeContent Text
text]

parseGemini :: Maybe String -> Txt.Text -> XML.Document
parseGemini :: Maybe String -> Text -> Document
parseGemini Maybe String
lang Text
txt = Document :: Prologue -> Element -> [Miscellaneous] -> Document
XML.Document {
        documentPrologue :: Prologue
XML.documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] Maybe Doctype
forall a. Maybe a
Nothing [],
        documentRoot :: Element
XML.documentRoot = Element :: Name -> Map Name Text -> [Node] -> Element
XML.Element {
            elementName :: Name
XML.elementName = Name
"body",
            elementAttributes :: Map Name Text
XML.elementAttributes = [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
                (Name
"lang", String -> Text
Txt.pack String
lang') | Just String
langs <- [Maybe String
lang], String
lang' <- [String -> String
csv String
langs]],
            elementNodes :: [Node]
XML.elementNodes = (Element -> Node) -> [Element] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Node
XML.NodeElement ([Element] -> [Node]) -> [Element] -> [Node]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Element]
parseGemini' ([Text] -> [Element]) -> [Text] -> [Element]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Txt.lines Text
txt
        },
        documentEpilogue :: [Miscellaneous]
XML.documentEpilogue = []
    }

csv :: String -> String
csv (Char
',':String
_) = String
""
csv (Char
c:String
rest) = Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String -> String
csv String
rest
csv String
"" = String
""

parseGemini' :: [Txt.Text] -> [XML.Element]
parseGemini' :: [Text] -> [Element]
parseGemini' ((Char
'#':.Char
'#':.Char
'#' :. Char
'#':.Char
'#':.Char
'#':.Text
line):[Text]
lines) =
    Name -> Text -> Element
el Name
"h6" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
parseGemini' ((Char
'#':.Char
'#':.Char
'#' :. Char
'#':.Char
'#':.Text
line):[Text]
lines) =
    Name -> Text -> Element
el Name
"h5" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
parseGemini' ((Char
'#':.Char
'#':.Char
'#' :. Char
'#':.Text
line):[Text]
lines) =
    Name -> Text -> Element
el Name
"h4" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
parseGemini' ((Char
'#':.Char
'#':.Char
'#':.Text
line):[Text]
lines) = Name -> Text -> Element
el Name
"h3" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
parseGemini' ((Char
'#':.Char
'#':.Text
line):[Text]
lines) = Name -> Text -> Element
el Name
"h2" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
parseGemini' ((Char
'#':.Text
line):[Text]
lines) = Name -> Text -> Element
el Name
"h1" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
-- Not properly structured, but still sounds fine...
parseGemini' ((Char
'*':.Text
line):[Text]
lines) = Name -> Text -> Element
el Name
"li" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
parseGemini' ((Char
'>':.Text
line):[Text]
lines) = Name -> Text -> Element
el Name
"blockquote" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines

parseGemini' ((Char
'=':.Char
'>':.Text
line):[Text]
lines)
    | (Text
url:text :: [Text]
text@(Text
_:[Text]
_)) <- Text -> [Text]
Txt.words Text
line = (Name -> Text -> Element
el Name
"a" (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Txt.unwords [Text]
text) {
            elementAttributes :: Map Name Text
XML.elementAttributes = Name -> Text -> Map Name Text -> Map Name Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
"href" Text
url Map Name Text
forall k a. Map k a
M.empty
        } Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
    | Bool
otherwise = (Name -> Text -> Element
el Name
"a" (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ Text -> Text
Txt.strip Text
line) {
            elementAttributes :: Map Name Text
XML.elementAttributes = Name -> Text -> Map Name Text -> Map Name Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
"href" (Text -> Text
Txt.strip Text
line) Map Name Text
forall k a. Map k a
M.empty
        } Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
parseGemini' ((Char
'`':.Char
'`':.Char
'`':.Text
line):[Text]
lines) = Name -> Text -> Element
el Name
"p" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
go [Text]
lines
    where
        go :: [Text] -> [Element]
go ((Char
'`':.Char
'`':.Char
'`':.Text
_):[Text]
lines) = [Text] -> [Element]
parseGemini' [Text]
lines
        go (Text
_:[Text]
lines) = [Text] -> [Element]
go [Text]
lines
        go [] = []
parseGemini' (Text
"```":[Text]
lines) = [Text] -> [Text] -> [Element]
go [] [Text]
lines
    where
        go :: [Text] -> [Text] -> [Element]
go [Text]
texts ((Char
'`':.Char
'`':.Char
'`':.Text
_):[Text]
lines) =
            Name -> Text -> Element
el Name
"pre" ([Text] -> Text
Txt.unlines [Text]
texts) Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
        go [Text]
texts (Text
line:[Text]
lines) = [Text] -> [Text] -> [Element]
go ([Text]
texts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
line]) [Text]
lines
        go [Text]
texts [] = []

parseGemini' (Text
line:[Text]
lines) = Name -> Text -> Element
el Name
"p" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
parseGemini' [] = []

--------
---- TSV, CSV, etc
--------

parseDelimitedValues :: Char -> Text -> [Text] -> [[Text]] -> [[Text]]
parseDelimitedValues Char
_ Text
"" [Text]
row [[Text]]
rows = [[Text]] -> [[Text]]
forall a. [a] -> [a]
reverse ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
row [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: [[Text]]
rows)
parseDelimitedValues Char
delim (Char
'\r':.Text
cs) [Text]
row [[Text]]
rows = Char -> Text -> [Text] -> [[Text]] -> [[Text]]
parseDelimitedValues Char
delim Text
cs [Text]
row [[Text]]
rows
parseDelimitedValues Char
delim (Char
'\n':.Text
cs) [Text]
row [[Text]]
rows = Char -> Text -> [Text] -> [[Text]] -> [[Text]]
parseDelimitedValues Char
delim Text
cs [] ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
row [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: [[Text]]
rows)
parseDelimitedValues Char
delim (Char
c:.Char
'"':.Text
cs) [Text]
row [[Text]]
rows | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim =
        let (Text
value, Text
cs') = Text -> (Text, Text)
inner Text
cs in Char -> Text -> [Text] -> [[Text]] -> [[Text]]
parseDelimitedValues Char
delim Text
cs' (Text
valueText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
row) [[Text]]
rows
    where
        inner :: Text -> (Text, Text)
inner (Char
x:.Char
y:.Text
cs) | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim Bool -> Bool -> Bool
&& Char
y Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim = let (Text
a, Text
b) = Text -> (Text, Text)
inner Text
cs in (Char
delim Char -> Text -> Text
`Txt.cons` Text
a, Text
b)
        inner (Char
c:.Text
cs) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim = (Text
"", Text
cs)
            | Bool
otherwise = let (Text
a, Text
b) = Text -> (Text, Text)
inner Text
cs in (Char
c Char -> Text -> Text
`Txt.cons` Text
a, Text
b)
        inner Text
"" = (Text
"", Text
"")
parseDelimitedValues Char
delim (Char
c:.Text
cs) [Text]
row [[Text]]
rows | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim =
    let (Text
value, Text
cs') = (Char -> Bool) -> Text -> (Text, Text)
Txt.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\r', Char
'\n', Char
delim]) Text
cs
    in Char -> Text -> [Text] -> [[Text]] -> [[Text]]
parseDelimitedValues Char
delim Text
cs' (Text
valueText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
row) [[Text]]
rows
parseDelimitedValues Char
delim Text
cs [Text]
row [[Text]]
rows =
    let (Text
value, Text
cs') = (Char -> Bool) -> Text -> (Text, Text)
Txt.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\r', Char
'\n', Char
delim]) Text
cs
    in Char -> Text -> [Text] -> [[Text]] -> [[Text]]
parseDelimitedValues Char
delim Text
cs (Text
valueText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
row) [[Text]]
rows

escapeDelimitedValues :: Char -> Text -> [[Text]]
escapeDelimitedValues Char
delim Text
source = ([Text] -> [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
inner) ([[Text]] -> [[Text]]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ Char -> Text -> [Text] -> [[Text]] -> [[Text]]
parseDelimitedValues Char
delim Text
source [] []
    where
        inner :: Text -> Text
inner = Text -> Text
Txt.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Txt.replace Text
"\\\\" Text
"\\" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Txt.replace Text
"\\n" Text
"\n" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Txt.replace Text
"\\t" Text
"\t" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Txt.replace Text
"\\r" Text
"\r"

parseDelimitedToTable :: Char -> Text -> Document
parseDelimitedToTable Char
delim Text
source
    | ([Text]
head:[[Text]]
body) <- ([Text] -> Bool) -> [[Text]] -> [[Text]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Text]] -> [[Text]]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ Char -> Text -> [[Text]]
escapeDelimitedValues Char
delim Text
source =
        Document :: Prologue -> Element -> [Miscellaneous] -> Document
XML.Document {
            documentPrologue :: Prologue
XML.documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] Maybe Doctype
forall a. Maybe a
Nothing [],
            documentRoot :: Element
XML.documentRoot = Element :: Name -> Map Name Text -> [Node] -> Element
XML.Element {
                elementName :: Name
XML.elementName = Name
"table",
                elementAttributes :: Map Name Text
XML.elementAttributes = Map Name Text
forall k a. Map k a
M.empty,
                elementNodes :: [Node]
XML.elementNodes = Name -> [Text] -> Node
rowToTr Name
"th" [Text]
head Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: ([Text] -> Node) -> [[Text]] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> [Text] -> Node
rowToTr Name
"td") [[Text]]
body
            },
            documentEpilogue :: [Miscellaneous]
XML.documentEpilogue = []
        }
    | Bool
otherwise = Document :: Prologue -> Element -> [Miscellaneous] -> Document
XML.Document { -- Empty TSV/CSV/etc
        documentPrologue :: Prologue
XML.documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] Maybe Doctype
forall a. Maybe a
Nothing [],
        documentRoot :: Element
XML.documentRoot = Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"table" Map Name Text
forall k a. Map k a
M.empty [],
        documentEpilogue :: [Miscellaneous]
XML.documentEpilogue = []
    }
rowToTr :: Name -> [Text] -> Node
rowToTr Name
tagname [Text]
values = Element -> Node
XML.NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"tr" Map Name Text
forall k a. Map k a
M.empty ([Node] -> Element) -> [Node] -> Element
forall a b. (a -> b) -> a -> b
$ (Text -> Node) -> [Text] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Node
inner [Text]
values
    where
        inner :: Text -> Node
inner = Element -> Node
XML.NodeElement (Element -> Node) -> (Text -> Element) -> Text -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Map Name Text -> [Node] -> Element
XML.Element Name
tagname Map Name Text
forall k a. Map k a
M.empty ([Node] -> Element) -> (Text -> [Node]) -> Text -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Node]
forall {a}. a -> [a]
singleton (Node -> [Node]) -> (Text -> Node) -> Text -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Node
XML.NodeContent
        singleton :: a -> [a]
singleton a
a = [a
a]