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

loadVisited :: String -> IO (Set Text)
loadVisited :: String -> IO (Set Text)
loadVisited appname :: String
appname = do
    String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
appname
    let path :: String
path = String
dir 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 | _:uri :: String
uri:_ <- (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 path :: String
path = Text -> String
Txt.unpack (Text -> String) -> IO Text -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
Txt.readFile String
path

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

fetchDocument :: Session -> Page styles -> URI -> IO (Page styles)
fetchDocument http :: Session
http referer :: 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 http :: Session
http referer :: 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 http :: Session
http referer :: 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 (-1)
fetchDocument http :: Session
http referer :: 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 1
fetchDocument http :: Session
http referer :: Page styles
referer URI {
        uriScheme :: URI -> String
uriScheme = String
"action:", uriPath :: URI -> String
uriPath = 'h':'i':'s':'t':'o':'r':'y':'/':x :: String
x
    } | Just x' :: 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 http :: Session
http referer :: 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 = "", icon :: URI
icon = URI
nullURI, description :: String
description = "",
        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 http :: 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 = "" } URI -> URI -> Bool
forall a. Eq a => a -> a -> Bool
== URI
uri0 { uriFragment :: String
uriFragment = "" } = 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 http :: Session
http referer :: Page styles
referer uri :: 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 :: Page style -> Integer -> Page style
shiftHistory self :: Page style
self 0 = Page style
self
shiftHistory self :: Page style
self@Page { backStack :: forall styles. Page styles -> [(String, URI)]
backStack = (title :: String
title, url :: URI
url):bs :: [(String, URI)]
bs } delta :: Integer
delta | Integer
delta Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 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 = (title :: String
title, url :: URI
url):fs :: [(String, URI)]
fs } delta :: Integer
delta | Integer
delta Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 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 self :: Page style
self _ = 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} sess :: Session
sess saveHist :: Bool
saveHist resp :: (URI, String, Either Text ByteString)
resp@(URI {uriFragment :: URI -> String
uriFragment = String
anch}, mime :: String
mime, _) = 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 = "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 :: Page s
-> Session -> (URI, String, Either Text ByteString) -> IO (Page s)
parseDocument ref :: Page s
ref sess :: Session
sess (uri :: URI
uri, "html/x-error\t", resp :: 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 = "error" } Session
sess (URI
uri, "text/html", Either Text ByteString
resp)
parseDocument p :: Page s
p _ (uri :: URI
uri, "text/html", Left text :: 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 p :: Page s
p _(uri :: URI
uri, "text/html", Right bytes :: 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 p :: Page s
p _
        (uri :: URI
uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang :: String
lang, Left text :: 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 p :: Page s
p _
        (uri :: URI
uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang :: String
lang, Right bytes :: 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 p :: Page s
p _ (uri :: URI
uri, "text/gemini", Left text :: 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 p :: Page s
p _ (uri :: URI
uri, "text/gemini", Right bytes :: 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 a :: Page s
a b :: Session
b (a' :: URI
a', b' :: String
b'@String
"text/css", Right bytes :: 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} _
    (uri :: URI
uri, "text/css", Left text :: Text
text)
  | URI {uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just host :: 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
</> "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' "document") URI
uri Text
text
    }
  absolutizeCSS :: Token -> Token
absolutizeCSS (CSSTok.Url text :: Text
text) | Just rel :: 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 tok :: Token
tok = Token
tok
parseDocument ref :: Page s
ref _ (uri :: URI
uri, "text/csv", Left body :: 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 ',' Text
body
parseDocument ref :: Page s
ref _ (uri :: URI
uri, "text/tab-separated-values", Left body :: 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 '\t' Text
body
parseDocument ref :: Page s
ref _ (uri :: URI
uri, "text/csv", Right body :: 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 ',' (Text -> Document) -> Text -> Document
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
utf8' ByteString
body
parseDocument ref :: Page s
ref _ (uri :: URI
uri, "text/tab-separated-values", Right body :: 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 '\t' (Text -> Document) -> Text -> Document
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
utf8' ByteString
body

parseDocument ref :: Page s
ref sess :: Session
sess (uri :: URI
uri, mime :: String
mime, body :: 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
/= ';') String
mime
parseDocument p :: Page s
p _ (uri :: URI
uri, _, Left text :: Text
text)
    | Right doc :: 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 p :: Page s
p _ (uri :: URI
uri, _, Right bytes :: ByteString
bytes)
    | Right doc :: 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 p :: Page s
p _ (uri :: URI
uri, 't':'e':'x':'t':'/':_, Right bytes :: 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 p :: Page s
p sess :: Session
sess resp :: (URI, String, Either Text ByteString)
resp@(uri :: URI
uri, mime :: String
mime, _) = 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 = "file:",
        uriAuthority :: Maybe URIAuth
uriAuthority = URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (String -> String -> String -> URIAuth
URIAuth "" "" "")
    } 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 "Unsupported filetype" Maybe String
ret

pageForText :: Page s -> URI -> Text -> IO (Page s)
pageForText referer :: Page s
referer uri :: URI
uri txt :: 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 = "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 :: 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
uri doc :: 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
        Nothing -> IO s
authorStyle
        Just host :: URIAuth
host -> do
            String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig String
appname
            let path :: String
path = String
dir 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 hist :: 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
</> "history.gmni") (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ '\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " " [
        "=>", 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 "title" _ childs :: [Node]
childs) = [Text] -> Text
Txt.concat [Text
txt | XML.NodeContent txt :: Text
txt <- [Node]
childs]
    getTitle (XML.Element "h1" _ childs :: [Node]
childs) = [Text] -> Text
Txt.concat [Text
txt | XML.NodeContent txt :: Text
txt <- [Node]
childs]
    getTitle (XML.Element _ _ childs :: [Node]
childs)
        | title :: Text
title:_ <- [Element -> Text
getTitle Element
el | XML.NodeElement el :: Element
el <- [Node]
childs] = Text
title
        | Bool
otherwise = ""

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

--------
---- CSS charset sniffing
--------
applyCSScharset :: [String] -> ByteString -> Text
applyCSScharset (charset :: String
charset:charsets :: [String]
charsets) bytes :: 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 _ bytes :: ByteString
bytes = String -> ByteString -> Text
convertCharset "utf-8" ByteString
bytes
cssCharset :: [Token] -> Text
cssCharset toks :: [Token]
toks | (CSSTok.AtKeyword "charset":toks' :: [Token]
toks') <- [Token] -> [Token]
skipCSSspace [Token]
toks,
        (CSSTok.String charset :: Text
charset:_) <- [Token] -> [Token]
skipCSSspace [Token]
toks' = Text
charset
    | Bool
otherwise = ""
skipCSSspace :: [Token] -> [Token]
skipCSSspace (CSSTok.Whitespace:toks :: [Token]
toks) = [Token] -> [Token]
skipCSSspace [Token]
toks
skipCSSspace toks :: [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
name text :: 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 lang :: Maybe String
lang txt :: 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 = "body",
            elementAttributes :: Map Name Text
XML.elementAttributes = [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
                ("lang", String -> Text
Txt.pack String
lang') | Just langs :: 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 (',':_) = ""
csv (c :: Char
c:rest :: String
rest) = Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String -> String
csv String
rest
csv "" = ""

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

parseGemini' (('=':.'>':.line :: Text
line):lines :: [Text]
lines)
    | (url :: Text
url:text :: [Text]
text@(_:_)) <- Text -> [Text]
Txt.words Text
line = (Name -> Text -> Element
el "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 "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 "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 "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' (('`':.'`':.'`':.line :: Text
line):lines :: [Text]
lines) = Name -> Text -> Element
el "p" Text
line Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
go [Text]
lines
    where
        go :: [Text] -> [Element]
go (('`':.'`':.'`':._):lines :: [Text]
lines) = [Text] -> [Element]
parseGemini' [Text]
lines
        go (_:lines :: [Text]
lines) = [Text] -> [Element]
go [Text]
lines
        go [] = []
parseGemini' ("```":lines :: [Text]
lines) = [Text] -> [Text] -> [Element]
go [] [Text]
lines
    where
        go :: [Text] -> [Text] -> [Element]
go texts :: [Text]
texts (('`':.'`':.'`':._):lines :: [Text]
lines) =
            Name -> Text -> Element
el "pre" ([Text] -> Text
Txt.unlines [Text]
texts) Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Text] -> [Element]
parseGemini' [Text]
lines
        go texts :: [Text]
texts (line :: Text
line:lines :: [Text]
lines) = [Text] -> [Text] -> [Element]
go ([Text]
texts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
line]) [Text]
lines
        go texts :: [Text]
texts [] = []

parseGemini' (line :: Text
line:lines :: [Text]
lines) = Name -> Text -> Element
el "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 _ "" row :: [Text]
row rows :: [[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 delim :: Char
delim ('\r':.cs :: Text
cs) row :: [Text]
row rows :: [[Text]]
rows = Char -> Text -> [Text] -> [[Text]] -> [[Text]]
parseDelimitedValues Char
delim Text
cs [Text]
row [[Text]]
rows
parseDelimitedValues delim :: Char
delim ('\n':.cs :: Text
cs) row :: [Text]
row rows :: [[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 delim :: Char
delim (c :: Char
c:.'"':.cs :: Text
cs) row :: [Text]
row rows :: [[Text]]
rows | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim =
        let (value :: Text
value, cs' :: 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 (x :: Char
x:.y :: Char
y:.cs :: 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 (a :: Text
a, b :: Text
b) = Text -> (Text, Text)
inner Text
cs in (Char
delim Char -> Text -> Text
`Txt.cons` Text
a, Text
b)
        inner (c :: Char
c:.cs :: Text
cs) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim = ("", Text
cs)
            | Bool
otherwise = let (a :: Text
a, b :: Text
b) = Text -> (Text, Text)
inner Text
cs in (Char
c Char -> Text -> Text
`Txt.cons` Text
a, Text
b)
        inner "" = ("", "")
parseDelimitedValues delim :: Char
delim (c :: Char
c:.cs :: Text
cs) row :: [Text]
row rows :: [[Text]]
rows | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim =
    let (value :: Text
value, cs' :: Text
cs') = (Char -> Bool) -> Text -> (Text, Text)
Txt.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['\r', '\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 delim :: Char
delim cs :: Text
cs row :: [Text]
row rows :: [[Text]]
rows =
    let (value :: Text
value, cs' :: Text
cs') = (Char -> Bool) -> Text -> (Text, Text)
Txt.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['\r', '\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 delim :: Char
delim source :: 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
. Text -> Text -> Text -> Text
Txt.replace "\\\\" "\\" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Txt.replace "\\n" "\n" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            Text -> Text -> Text -> Text
Txt.replace "\\t" "\t" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Txt.replace "\\r" "\r"

parseDelimitedToTable :: Char -> Text -> Document
parseDelimitedToTable delim :: Char
delim source :: Text
source
    | (head :: [Text]
head:body :: [[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 = "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 "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 "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 "table" Map Name Text
forall k a. Map k a
M.empty [],
        documentEpilogue :: [Miscellaneous]
XML.documentEpilogue = []
    }
rowToTr :: Name -> [Text] -> Node
rowToTr tagname :: Name
tagname values :: [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 "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
a]