From 8f9c51474f8cad8cd2337f9231d95fd8e7f7e258 Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Sun, 5 Nov 2017 07:55:04 +0300
Subject: Allow to set document types explicitly

---
 Pancake/Command.hs |  8 +++++---
 Pancake/Reading.hs | 39 +++++++++++++++++++++------------------
 2 files changed, 26 insertions(+), 21 deletions(-)

(limited to 'Pancake')

diff --git a/Pancake/Command.hs b/Pancake/Command.hs
index 46a3e66..a1a0b09 100644
--- a/Pancake/Command.hs
+++ b/Pancake/Command.hs
@@ -23,7 +23,8 @@ import Pancake.Configuration
 data Command = Quit
              | Follow Int
              | More
-             | GoTo URI
+             | GoTo (Maybe String) URI
+             -- ^ Document type, URI
              | Reload
              | Back
              | Forward
@@ -61,8 +62,9 @@ showRef = char '?' *> (Show . read <$> many1 digit) <* eof
 -- | 'GoTo' command parser.
 goTo :: Parser Command
 goTo = do
-  s <- manyTill anyChar eof
-  maybe (fail "Failed to parse URI") (pure . GoTo) $ parseURIReference s
+  f <- optionMaybe (try (many1 alphaNum <* space)) <?> "type"
+  s <- manyTill anyChar eof <?> "URI"
+  maybe (fail "Failed to parse URI") (pure . GoTo f) $ parseURIReference s
 
 -- | 'Shortcut' command parser.
 shortcut :: M.Map String String -> Parser Command
diff --git a/Pancake/Reading.hs b/Pancake/Reading.hs
index 801cf43..d0a6ef4 100644
--- a/Pancake/Reading.hs
+++ b/Pancake/Reading.hs
@@ -84,31 +84,34 @@ retrieve cmd uri = do
 -- structure. The parser is chosen depending on the URI.
 readDoc :: String
         -- ^ Shell command to use for retrieval.
+        -> Maybe String
+        -- ^ Document type.
         -> URI
         -- ^ Document URI.
         -> IO (Either P.PandocError P.Pandoc)
         -- ^ A parsed document.
-readDoc cmd uri = do
+readDoc cmd dt uri = do
   out <- retrieve cmd uri
   term <- setupTermFromEnv
   let reader = either (const plain) id $
-        case (uriScheme uri, map toLower $ takeExtension $ uriPath uri) of
-          -- some exceptions and special cases (might be better to make
-          -- this configurable)
-          ("http:", ext) -> http ext
-          ("https:", ext) -> http ext
-          ("gopher:", ext) -> case uriPath uri of
-            ('/':'1':_) -> gopher
-            ('/':'h':_) -> html
-            -- "0" should indicate plain text, but it's also the most
-            -- suitable option for non-html markup. Not sure about this
-            -- approach, but it's similar to ignoring HTTP content-type,
-            -- and will do for now: better to render documents nicely
-            -- when possible.
-            ('/':'0':_) -> byExtension ext
-            -- unknown or unrecognized item type
-            _ -> byExtension ext <|> gopher
-          (_, ext) -> byExtension ext
+        maybe (Left "no type suggestions") (byExtension . ('.':)) dt
+         <|> case (uriScheme uri, map toLower $ takeExtension $ uriPath uri) of
+               -- some exceptions and special cases (might be better to make
+               -- this configurable)
+               ("http:", ext) -> http ext
+               ("https:", ext) -> http ext
+               ("gopher:", ext) -> case uriPath uri of
+                 ('/':'1':_) -> gopher
+                 ('/':'h':_) -> html
+                 -- "0" should indicate plain text, but it's also the most
+                 -- suitable option for non-html markup. Not sure about this
+                 -- approach, but it's similar to ignoring HTTP content-type,
+                 -- and will do for now: better to render documents nicely
+                 -- when possible.
+                 ('/':'0':_) -> byExtension ext
+                 -- unknown or unrecognized item type
+                 _ -> byExtension ext <|> gopher
+               (_, ext) -> byExtension ext
       cols = maybe 80 id $ getCapability term termColumns
       opts = def { P.readerColumns = cols }
   case reader of
-- 
cgit v1.2.3