Allow to set document types explicitly

4 files changed, 49 insertions, 36 deletions

diff --git a/Pancake.hs b/Pancake.hs
index 44e40c7..e346d0c 100644
--- a/Pancake.hs
+++ b/Pancake.hs
@@ -76,8 +76,13 @@ updateConfig = do
 
 -- | Decides what to do with a given URI; either returns a document or
 -- runs an external viewer. Used by both 'GoTo' and 'Reload'.
-loadDocument :: MonadIO m => URI -> StateT LoopState m (URI, Maybe P.Pandoc)
-loadDocument u' = do
+loadDocument :: MonadIO m
+             => Maybe String
+             -- ^ Document type.
+             -> URI
+             -- ^ Document URI.
+             -> StateT LoopState m (URI, Maybe P.Pandoc)
+loadDocument t u' = do
   st <- get
   let ddg = isPrefixOf "/l/?kh=-1&uddg=" $ uriToString id u' ""
       u = case (ddg, uriIsAbsolute u', history st) of
@@ -92,13 +97,14 @@ loadDocument u' = do
         (_:s) -> s
       cmd = maybe (defaultCommand $ conf st) id $
         M.lookup uScheme (commands $ conf st)
-      ext = case takeExtension $ uriPath u of
-        ('.':xs) -> map toLower xs
-        other -> other
+      ext = case (t, takeExtension $ uriPath u) of
+        (Just x, _) -> x
+        (_, '.':xs) -> map toLower xs
+        (_, other) -> other
   d <- liftIO $ do
     case M.lookup ext (externalViewers $ conf st) of
       Nothing -> do
-        doc <- readDoc cmd u
+        doc <- readDoc cmd t u
         case doc of
           Left err -> do
             putErrLn $ show err
@@ -124,9 +130,9 @@ loadDocument u' = do
   pure (u, d)
 
 -- | Visits an URI, updates history accordingly.
-goTo :: MonadIO m => URI -> StateT LoopState m ()
-goTo u' = do
-  (u, d) <- loadDocument u'
+goTo :: MonadIO m => Maybe String -> URI -> StateT LoopState m ()
+goTo t u' = do
+  (u, d) <- loadDocument t u'
   case d of
     Nothing -> pure ()
     Just doc -> do
@@ -137,11 +143,11 @@ goTo u' = do
 
 -- | Evaluates user commands.
 command :: MonadIO m => Command -> StateT LoopState m ()
-command (GoTo u@(URI _ _ _ _ ('#':xs))) = do
+command (GoTo t u@(URI _ _ _ _ ('#':xs))) = do
   -- follow an URI first, if it's not just a fragment
   case u of
     (URI "" Nothing "" "" _) -> pure ()
-    _ -> goTo u
+    _ -> goTo t u
   -- get to the fragment
   st <- get
   case (lookup xs (rIdentifiers $ rendered st), embedded st) of
@@ -155,11 +161,11 @@ command (GoTo u@(URI _ _ _ _ ('#':xs))) = do
           drop (position st) (rLines $ rendered st)
         modify (\s -> s { position = x + lineCount - 2 })
     (Just x, True) -> putSexpLn ["goto", show x]
-command (GoTo u) = goTo u
+command (GoTo t u) = goTo t u
 command (Follow i) = do
   st <- get
   if length (rLinks $ rendered st) > i
-    then command (GoTo $ rLinks (rendered st) !! i)
+    then command (GoTo Nothing $ rLinks (rendered st) !! i)
     else liftIO $ putErrLn "No such link"
 command Back = do
   st <- get
@@ -189,7 +195,7 @@ command Reload = do
   st <- get
   case history st of
     ((u, _):prev, next) -> do
-      (_, d) <- loadDocument u
+      (_, d) <- loadDocument Nothing u
       case d of
         Nothing -> pure ()
         Just doc -> do
@@ -213,7 +219,7 @@ command ShowCurrent = do
   case history st of
     ((u, _):_, _) -> liftIO $ putErrLn $ show u
     _ -> pure ()
-command (Shortcut u q) = command . GoTo . fromJust . parseURI $
+command (Shortcut u q) = command . GoTo Nothing . fromJust . parseURI $
   u ++ escapeURIString isReserved q
 command ReloadConfig = updateConfig
 command Quit = liftIO $ do
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
diff --git a/README.org b/README.org
index 4e2d317..393cc92 100644
--- a/README.org
+++ b/README.org
@@ -29,6 +29,8 @@ your default emacs browser:
 - ?: show current URI
 - RET (empty): show the next 2/3 of a page, if pagination is enabled
 - <URI>: follow an URI, possibly relative to the current one
+- <type> <URI>: same as above, but explicitly set a document type
+  (html, txt, org, markdown, etc)
 - <shortcut> <query>: run a query using a shortcut defined in the
   configuration (e.g., search)