From 6740a349caa6c20513191bbf213570448352093f Mon Sep 17 00:00:00 2001 From: defanor Date: Sun, 5 Nov 2017 04:57:09 +0300 Subject: Split into modules --- Pancake.hs | 648 ++++--------------------------------------------------------- 1 file changed, 36 insertions(+), 612 deletions(-) (limited to 'Pancake.hs') diff --git a/Pancake.hs b/Pancake.hs index b479b49..eee505d 100644 --- a/Pancake.hs +++ b/Pancake.hs @@ -9,575 +9,34 @@ A CLI web\/gopher\/file browser inspired by -} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import qualified Text.Pandoc as P import System.FilePath -import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS import Data.Default import Network.URI import System.Process -import Control.Monad.Writer hiding ((<>)) +import Control.Monad.Writer import Control.Monad.State import Data.Maybe import Data.List -import Data.String import System.Console.Terminfo import System.Environment -import Data.Yaml -import GHC.Generics import qualified Data.Map as M import System.Directory import System.Exit -import GHC.IO.Handle import Control.Exception -import Text.Pandoc.Readers.Plain -import Text.Pandoc.Readers.Gopher -import Control.Applicative -import qualified System.IO as SIO import Data.Char -import Data.Text.Encoding (decodeUtf8', decodeLatin1) import System.IO.Error - --- | Prints a line into stderr. -putErrLn :: MonadIO m => String -> m () -putErrLn s = liftIO $ do - SIO.hPutStrLn SIO.stderr s - SIO.hFlush SIO.stderr - - --- * Document reading - --- | Retrieves a document. Prints an error message and returns an --- empty string on failure. -retrieve :: String - -- ^ Shell command to use for retrieval. - -> URI - -- ^ Document URI. - -> IO BS.ByteString - -- ^ Document contents. -retrieve cmd uri = do - putErrLn $ "Retrieving " ++ show uri - curEnv <- getEnvironment - let envAuthority = maybe [] (\x -> [ ("URI_USERINFO", uriUserInfo x) - , ("URI_REGNAME", uriRegName x) - , ("URI_PORT", uriPort x) ]) - (uriAuthority uri) - environment = ("URI", uriToString id uri "") - : ("URI_SCHEME", uriScheme uri) - : ("URI_PATH", uriPath uri) - : ("URI_QUERY", uriQuery uri) - : ("URI_FRAGMENT", uriFragment uri) - : curEnv - ++ envAuthority - handle (\(e :: SomeException) -> - putErrLn (concat ["Failed to run `", cmd, "`: ", show e]) - >> pure BS.empty) $ - withCreateProcess ((shell cmd) { env = Just environment - , std_out = CreatePipe - , std_err = CreatePipe - , delegate_ctlc = True }) $ - \_ stdout stderr ph -> case stdout of - Nothing -> putErrLn "No stdout" >> pure BS.empty - Just stdout' -> do - hSetBinaryMode stdout' True - out <- BS.hGetContents stdout' - ec <- waitForProcess ph - if (ec /= ExitSuccess) - then do - putErrLn $ concat ["An error occured. Exit code: ", show ec] - case stderr of - Nothing -> pure () - Just stderr' -> do - err <- BS.hGetContents stderr' - putErrLn $ "stderr:\n" ++ BS.unpack err - else putErrLn $ show uri - pure out - --- | Reads a document: retrieves it and parses into a Pandoc --- structure. The parser is chosen depending on the URI. -readDoc :: String - -- ^ Shell command to use for retrieval. - -> URI - -- ^ Document URI. - -> IO (Either P.PandocError P.Pandoc) - -- ^ A parsed document. -readDoc cmd 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 - cols = maybe 80 id $ getCapability term termColumns - opts = def { P.readerColumns = cols } - case reader of - (P.TextReader f, _) -> case decodeUtf8' out of - Left err -> do - putErrLn $ show err - P.runIO $ f opts $ decodeLatin1 out - Right r -> P.runIO $ f opts r - (P.ByteStringReader f, _) -> P.runIO $ f opts $ BL.fromStrict out - where - http ext = byExtension ext <|> html - html = P.getReader "html" - plain = (P.TextReader . const $ readPlain, P.emptyExtensions) - gopher = pure (P.TextReader . const $ readGopher, P.emptyExtensions) - byExtension "" = Left "No extension" - byExtension ".md" = P.getReader "markdown" - byExtension ".htm" = html - byExtension ".ltx" = P.getReader "latex" - byExtension ".tex" = P.getReader "latex" - byExtension ".txt" = pure plain - byExtension ext = P.getReader $ tail ext - - --- * Rendering - --- | The type of a list item that should be rendered next. -data Listing = Bulleted - | Ordered Int - deriving (Show, Eq) - --- | Renderer state. -data RS = RS { indentationLevel :: Int - , linkCount :: Int - , lineNumber :: Int - , listing :: Maybe Listing - , columns :: Int - } deriving (Show, Eq) - --- | A styled string. -data Styled = Plain String - | Underline Styled - | Bold Styled - | Emph Styled - | Fg Color Styled - deriving (Show, Eq) - --- | Just for convenience. -instance IsString Styled where - fromString = Plain - --- | A line of styled elements. -type StyledLine = [Styled] - --- | This is what gets rendered. -data RendererOutput = RLink URI - | RLine StyledLine - | RIdentifier String Int - deriving (Show, Eq) - --- | Extracts links. -rLinks :: [RendererOutput] -> [URI] -rLinks [] = [] -rLinks ((RLink l):xs) = l : rLinks xs -rLinks (_:xs) = rLinks xs - --- | Extracts text lines. -rLines :: [RendererOutput] -> [StyledLine] -rLines [] = [] -rLines ((RLine l):xs) = l : rLines xs -rLines (_:xs) = rLines xs - --- | Extracts identifiers. -rIdentifiers :: [RendererOutput] -> [(String, Int)] -rIdentifiers [] = [] -rIdentifiers ((RIdentifier s i):xs) = (s, i) : rIdentifiers xs -rIdentifiers (_:xs) = rIdentifiers xs - - --- | Used to render 'Pandoc' docs by writing text lines and collected --- links using 'Writer'. -type Renderer a = WriterT [RendererOutput] (State RS) a - --- | Runs a 'Renderer'. -runRenderer :: Int - -- ^ Column count (line width). - -> Int - -- ^ Link number to start with. - -> Int - -- ^ Line number to start with. - -> Renderer a - -- ^ A renderer. - -> [RendererOutput] - -- ^ Collected links and text lines. -runRenderer cols ls ln r = snd $ fst $ runState (runWriterT r) - (RS 0 ls ln Nothing cols) - --- | Stores a link, increasing the counter -storeLink :: URI -> Renderer Int -storeLink u = do - tell [RLink u] - st <- get - put (st { linkCount = linkCount st + 1 }) - pure $ linkCount st - --- | Stores text lines. -storeLines :: [StyledLine] -> Renderer () -storeLines l = do - modify (\s -> s { lineNumber = lineNumber s + length l }) - tell $ map RLine l - --- | Stores attributes (identifier and line number). -storeAttr :: P.Attr -> Renderer () -storeAttr ("", _, _) = pure () -storeAttr (i, _, _) = do - l <- get - tell [RIdentifier i (lineNumber l)] - --- | Increases indentation level, runs a renderer, decreases --- indentation level. -withIndent :: Renderer a -> Renderer a -withIndent x = do - modify (\s -> s { indentationLevel = indentationLevel s + 1 }) - r <- x - modify (\s -> s { indentationLevel = indentationLevel s - 1 }) - pure r - --- | Reads indentation level, runs a renderer, restores the original --- indentation level. -keepIndent :: Renderer a -> Renderer a -keepIndent r = do - st <- get - ret <- r - modify $ \s -> s { indentationLevel = indentationLevel st } - pure ret - --- | Renders indented (with the current indent level) lines. -indented :: [StyledLine] -> Renderer () -indented slines = do - st <- get - -- The following blocks of the same list item should not be marked. - modify $ \s -> s { listing = Nothing } - let il = indentationLevel st - prefix = case listing st of - Nothing -> "" - (Just Bulleted) -> Fg Yellow "* " - (Just (Ordered n)) -> Fg Yellow $ fromString $ show n ++ ". " - prefixLen = length $ unstyled [prefix] - indent = il + prefixLen - fittedLines = fitLines (columns st - indent) slines - pad = (fromString (replicate indent ' ') :) - padFirst = (\x -> fromString (replicate il ' ') : prefix : x) - -- The following blocks of the same list item should be indented - -- with the same level. This should be reset to the original value - -- where the listing type is getting set. - modify $ \s -> s { indentationLevel = indent } - case fittedLines of - [] -> pure () - (l:ls) -> storeLines $ padFirst l : map pad ls - --- This may be unreliable, especially for resulting length estimation, --- but usually works. Maybe improve someday. --- | Returns a string as it would be shown on a dumb terminal. -unstyled :: StyledLine -> String -unstyled = concatMap unstyled' - where - unstyled' (Plain s) = s - unstyled' (Main.Underline s) = unstyled' s - unstyled' (Main.Bold s) = unstyled' s - unstyled' (Main.Emph s) = unstyled' s - unstyled' (Fg _ s) = unstyled' s - --- | Fits words into terminal lines of a given width. -fitLines :: Int - -- ^ Line width. - -> [[Styled]] - -- ^ Strings: usually words and similar short elements. - -> [StyledLine] - -- ^ Fitted lines. -fitLines maxLen inlineBits = concatMap (map reverse . fitWords [] 0) inlineBits - where - fitWords :: [Styled] -> Int -> [Styled] -> [StyledLine] - -- fitWords curLine curLen (w:ws) = [[fromString $ show (w:ws)]] - fitWords curLine curLen (w:ws) - -- handle newline characters - | unstyled [w] == "\n" = curLine : fitWords [] 0 ws - -- a new line - | curLen == 0 = fitWords [w] (length $ unstyled [w]) ws - -- add a word to a line - | otherwise = let wLen = length (unstyled [w]) - spaceAhead = case ws of - (" " : _) -> True - _ -> False - in if curLen + wLen <= maxLen - then fitWords (w:curLine) (curLen + wLen) $ - -- if there's an unnecessary space ahead, skip it - if (curLen + wLen + 1 > maxLen && spaceAhead) - then tail ws - else ws - else curLine : fitWords [] 0 (w:ws) - -- end, no words pending - fitWords _ 0 [] = [] - -- end, with words pending - fitWords curLine _ [] = [curLine] - --- | A helper function to put inline elements between two strings --- (such as parens or quotes). -wrappedInlines :: Styled - -- ^ String on the left. - -> Styled - -- ^ String on the right. - -> [P.Inline] - -- ^ Inlines to wrap. - -> Renderer [Styled] - -- ^ Resulting inlines. -wrappedInlines s e r = do - r' <- concat <$> mapM readInline r - pure $ s : r' ++ [e] - --- | Reads an inline element, producing styled strings. Doesn't render --- them (i.e., using 'Writer') on its own, but collects links. -readInline :: P.Inline -> Renderer [Styled] -readInline (P.Str s) - | all isSpace s = pure [] - | otherwise = pure [fromString s] -readInline (P.Emph s) = concatMap (map Main.Emph) <$> mapM readInline s -readInline (P.Strong s) = concatMap (map Main.Bold) <$> mapM readInline s -readInline (P.Strikeout s) = wrappedInlines "-" "-" s -readInline (P.Superscript s) = wrappedInlines "^{" "}" s -readInline (P.Subscript s) = wrappedInlines "_{" "}" s -readInline (P.SmallCaps s) = wrappedInlines "\\sc{" "}" s -readInline (P.Quoted P.SingleQuote s) = wrappedInlines "‘" "’" s -readInline (P.Quoted P.DoubleQuote s) = wrappedInlines "“" "”" s -readInline (P.Cite _ s) = concat <$> mapM readInline s -readInline (P.Code attr s) = do - storeAttr attr - pure . map fromString $ intersperse "\n" $ lines s -readInline P.Space = pure [" "] -readInline P.SoftBreak = pure [" "] -readInline P.LineBreak = pure ["\n"] -readInline (P.Math _ s) = pure [fromString s] -readInline (P.RawInline _ s) = pure [fromString s] -readInline (P.Link attr alt (url, title)) = do - storeAttr attr - case parseURIReference url of - Just uri -> do - a <- mapM readInline alt - let t = case (title, concat a) of - ("", []) -> [fromString url] - ("", alt') -> alt' - (title', []) -> [fromString title'] - (_, alt') -> alt' - cnt <- storeLink uri - let color = case uri of - (URI "" Nothing "" "" ('#':_)) -> Magenta - _ -> Cyan - pure $ (map $ Fg color) t ++ - [Fg Blue $ fromString (concat ["[", show cnt, "]"])] - Nothing -> pure [fromString title] -readInline (P.Image attr alt (url, title)) = do - storeAttr attr - (Fg Red "img:" :) <$> case parseURIReference url of - Nothing -> pure [fromString title] - Just uri -> do - a <- mapM readInline alt - let t = case (title, concat a) of - ("", []) -> [fromString $ takeFileName $ uriPath uri] - ("", alt') -> alt' - (title', []) -> [fromString title'] - (_, alt') -> alt' - cnt <- storeLink uri - pure $ (map $ Fg Cyan) t ++ - [Fg Blue $ fromString (concat ["[", show cnt, "]"])] -readInline (P.Note _) = pure . pure $ "(note: todo)" -readInline (P.Span attr i) = do - storeAttr attr - concat <$> mapM readInline i - --- | Reads lines of inline elements. -readInlines :: [P.Inline] -> Renderer [StyledLine] -readInlines i = pure . concat <$> mapM readInline i - --- | Renders a block element. -renderBlock :: P.Block -> Renderer () -renderBlock (P.Plain i) = indented =<< readInlines i -renderBlock (P.Para i) = (indented =<< readInlines i) >> storeLines [[""]] -renderBlock (P.LineBlock i) = - indented =<< concat <$> mapM (mapM readInline) i -renderBlock (P.CodeBlock attr s) = do - storeAttr attr - indented $ map (pure . fromString) $ lines s -renderBlock (P.RawBlock _ s) = - indented $ map (pure . fromString) $ lines s -renderBlock (P.BlockQuote bs) = renderBlocks bs -renderBlock (P.OrderedList _ bs) = do - zipWithM_ (\b n -> modify (\s -> s { listing = Just (Ordered n) }) - >> keepIndent (mapM_ renderBlock b)) bs [1..] - modify $ \s -> s { listing = Nothing } -renderBlock (P.BulletList bs) = do - mapM_ (\b -> modify (\s -> s { listing = Just Bulleted }) - >> keepIndent (mapM_ renderBlock b)) bs - modify $ \s -> s { listing = Nothing } -renderBlock (P.DefinitionList dl) = - let renderDefinition (term, definition) = do - indented =<< readInlines term - mapM_ renderBlocks definition - in mapM_ renderDefinition dl -renderBlock (P.Header level attr i) = do - storeAttr attr - strings <- readInlines i - storeLines [[""]] - indented $ map (map (Fg Green) . ([fromString (replicate level '#'), " "] ++) - . (map (Main.Bold . Main.Underline))) strings - storeLines [[""]] -renderBlock P.HorizontalRule = do - st <- get - indented [[Fg Black $ - fromString $ replicate (columns st - indentationLevel st * 2) '-']] -renderBlock (P.Table caption _ widths headers rows) = do - -- todo: don't ignore alignments - indented =<< readInlines caption - -- Use pandoc-provided widths if they are set, calculate them - -- otherwise. - let widthsAreSet = case widths of - [] -> False - w -> minimum w /= maximum w - ws <- if widthsAreSet then pure widths else do - lens <- map sum . transpose <$> - mapM (mapM (\c -> (length . unstyled . concat) <$> tableCell 80 c)) rows - pure $ map (\l -> fromIntegral l / fromIntegral (sum lens)) lens - mapM_ (\r -> renderBlock P.HorizontalRule >> tableRow ws r) (headers : rows) - renderBlock P.HorizontalRule - where - tableCell :: Int -> [P.Block] -> Renderer [StyledLine] - tableCell w blocks = do - st <- get - let l = runRenderer w (linkCount st) (lineNumber st) $ - mapM_ renderBlock blocks - mapM_ storeLink $ rLinks l - pure $ map - (\x -> x ++ [fromString (replicate (w - length (unstyled x)) ' ')]) - $ rLines l - tableRow :: [Double] -> [[P.Block]] -> Renderer () - tableRow ws cols = do - st <- get - let maxWidth = columns st - indentationLevel st - ((length cols - 1) * 3) - widths' = map (\w -> floor (fromIntegral maxWidth * w)) ws - cells <- zipWithM tableCell widths' cols - let maxLines = foldr (max . length) 0 cells - padded = zipWith (\w c -> c ++ replicate (maxLines - length c) - [fromString $ replicate w ' ']) widths' cells - indented $ map (mconcat . intersperse (pure $ Fg Black " | ")) - $ transpose padded -renderBlock (P.Div attr b) = do - storeAttr attr - renderBlocks b -renderBlock P.Null = pure () - --- | Renders multiple block elements. -renderBlocks :: [P.Block] -> Renderer () -renderBlocks b = withIndent $ mapM_ renderBlock b - - --- * Configuration - --- | Application configuration. -data Config = Config { commands :: M.Map String String - -- ^ URI schemes and corresponding shell commands - -- for downloading. - , defaultCommand :: String - -- ^ A command to use if no other command - -- applies. - , externalViewers :: M.Map String String - -- ^ File extensions and corresponding external - -- applications. - , shortcuts :: M.Map String String - -- ^ Shortcuts to use (search engines, - -- dictionaries, etc). - , paginate :: Bool - -- ^ Enable pagination in non-embedded mode; - -- print everything at once otherwise. - , historyDepth :: Int - -- ^ The amount of history entries (into either - -- direction) to keep. - } deriving (Generic, Show) - --- | For configuration parsing. -instance FromJSON Config --- | For configuration writing, particularly that of default --- configuration if it is missing. -instance ToJSON Config --- | The default configuration to use if user configuration is --- missing. -instance Default Config where - def = Config { - commands = M.fromList - [ ("ssh", "scp \"${URI_REGNAME}:${URI_PATH}\" /dev/stdout") - , ("gopher", "curl \"${URI}\"")] - , defaultCommand = "curl -4 -L \"${URI}\"" - , externalViewers = M.fromList $ - map (flip (,) "emacsclient -n \"${FILE}\"") - ["hs", "cabal", "c", "h", "el", "scm", "idr"] - ++ map (flip (,) "xdg-open \"${FILE}\"") - [ "svg", "png", "jpg", "jpeg", "gif", "pdf", "ogg", "ogv" - , "webm", "mp3", "mp4", "mkv", "mpeg", "wav" ] - , shortcuts = M.fromList - [ ("ddg", "https://duckduckgo.com/lite/?q=") - , ("wp", "https://en.m.wikipedia.org/wiki/Special:Search?search=") - , ("wt", "https://en.m.wiktionary.org/w/index.php?search=") - , ("gp", "gopher://gopherpedia.com:70/7/lookup?") - , ("vs", "gopher://gopher.floodgap.com/7/v2/vs?")] - , paginate = True - , historyDepth = 100 - } - --- | Loads configuration from an XDG config directory. -loadConfig :: MonadIO m => StateT LoopState m () -loadConfig = do - c <- liftIO $ do - dir <- getXdgDirectory XdgConfig "pancake" - createDirectoryIfMissing True dir - let configPath = dir "config.yaml" - exists <- doesFileExist configPath - if exists - then do - c <- decodeFile configPath - case c of - Just config -> pure config - Nothing -> putErrLn "Failed to read the configuration, using defaults" - >> pure def - else encodeFile configPath (def :: Config) >> pure def - modify $ \s -> s {conf = c} - - --- * Control - --- | Interactive user command. -data Command = Quit - | Follow Int - | More - | GoTo URI - | Reload - | Back - | Forward - | Help - | Show Int - | ShowCurrent - | Shortcut String String - | ReloadConfig - deriving (Show, Eq) +import Pancake.Common +import Pancake.Configuration +import Pancake.Reading +import Pancake.Rendering +import Pancake.Printing -- | A zipper kind of thing, for scrolling and history traversal. type Sliding a = ([a], [a]) @@ -590,69 +49,13 @@ data LoopState = LS { history :: Sliding (URI, P.Pandoc) , embedded :: Bool } deriving (Show) --- | Propertizes a styled string for a given terminal. -propertize :: Terminal -> Styled -> TermOutput -propertize _ (Plain s) = termText s -propertize t (Fg clr s) = maybe id (\f -> f clr) - (getCapability t withForegroundColor) $ propertize t s -propertize t (Main.Bold s) = - maybe id id (getCapability t withBold) $ propertize t s -propertize t (Main.Emph s) = - maybe id id (getCapability t withStandout) $ propertize t s -propertize t (Main.Underline s) = - maybe id id (getCapability t withUnderline) $ propertize t s - --- | Prints rendered lines. -showLines :: MonadIO m => [StyledLine] -> StateT LoopState m () -showLines ls = liftIO $ do - term <- setupTermFromEnv - let nl = maybe (termText "\n") id $ getCapability term newline - runTermOutput term . mconcat $ - map (\l -> mconcat (map (propertize term) l) <#> nl) ls - --- | Shows a list of strings as an s-expression -list :: [String] -> String -list l = "(" ++ intercalate " " l ++ ")" - --- | Prints a list of strings as an s-expression. -putSexpLn :: MonadIO m => [String] -> StateT LoopState m () -putSexpLn s = liftIO $ do - putStrLn $ list s - SIO.hFlush SIO.stdout - --- | Prints rendered lines as s-expressions. -showSexps :: MonadIO m => [RendererOutput] -> StateT LoopState m () -showSexps ro = - -- would be nicer to use some library for this, but they tend to be - -- abandoned, and the task is simple enough to do it here - putSexpLn [ "render" - , list $ "lines" : - map (list . pure . concat . intersperse " " . map showSexp) - (rLines ro) - , list $ "identifiers" - : map (\(i, l) -> list [encodeStr i, show l]) (rIdentifiers ro) - , list $ "links" - : map (\uri -> encodeStr $ uriToString id uri "") (rLinks ro)] - where - encodeStr s = concat ["\"", concatMap escape s, "\""] - escape '\\' = "\\\\" - escape '"' = "\\\"" - escape '\n' = "\\n" - escape other = pure other - showSexp :: Styled -> String - showSexp (Plain s) = encodeStr s - showSexp (Fg clr s) = list ["fg", show clr, showSexp s] - showSexp (Bold s) = list ["style", "bold", showSexp s] - showSexp (Underline s) = list ["style", "underline", showSexp s] - showSexp (Emph s) = list ["style", "italic", showSexp s] - -- | Renders a parsed document. -renderDoc :: MonadIO m => P.Pandoc -> StateT LoopState m () -renderDoc (P.Pandoc _ blocks) = do +printDoc :: MonadIO m => P.Pandoc -> StateT LoopState m () +printDoc doc = do term <- liftIO setupTermFromEnv st <- get let cols = maybe 80 id $ getCapability term termColumns - l = runRenderer cols 0 1 $ mapM_ renderBlock blocks + l = renderDoc cols doc textLines = rLines l modify (\s -> s { rendered = l }) if embedded st @@ -664,6 +67,12 @@ renderDoc (P.Pandoc _ blocks) = do else textLines modify (\s -> s { position = rows }) +-- | Updates 'LoopState' with user configuration. +updateConfig :: MonadIO m => StateT LoopState m () +updateConfig = do + c <- loadConfig + modify $ \s -> s { conf = c } + -- | 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) @@ -720,11 +129,26 @@ goTo u' = do case d of Nothing -> pure () Just doc -> do - renderDoc doc + printDoc doc modify $ \s -> let (prev, _) = history s in s { history = (take (historyDepth $ conf s) $ (u, doc) : prev, []) } +-- | Interactive user command. +data Command = Quit + | Follow Int + | More + | GoTo URI + | Reload + | Back + | Forward + | Help + | Show Int + | ShowCurrent + | Shortcut String String + | ReloadConfig + deriving (Show, Eq) + -- | Evaluates user commands. command :: MonadIO m => Command -> StateT LoopState m () command (GoTo u@(URI _ _ _ _ ('#':xs))) = do @@ -755,7 +179,7 @@ command Back = do st <- get case history st of (cur:p@(_, d):prev, next) -> do - renderDoc d + printDoc d modify $ \s -> s { history = (p:prev, take (historyDepth $ conf s) $ cur : next) } _ -> liftIO $ putErrLn "There's nothing back there" @@ -763,7 +187,7 @@ command Forward = do st <- get case history st of (prev, n@(_, d):next) -> do - renderDoc d + printDoc d modify $ \s -> s { history = (take (historyDepth $ conf s) $ n : prev, next) } _ -> liftIO $ putErrLn "Nowhere to go" @@ -783,7 +207,7 @@ command Reload = do case d of Nothing -> pure () Just doc -> do - renderDoc doc + printDoc doc modify $ \s -> s { history = ( (u, doc):prev, next ) } _ -> putErrLn "There's nothing to reload" command Help = do @@ -805,7 +229,7 @@ command ShowCurrent = do _ -> pure () command (Shortcut u q) = command . GoTo . fromJust . parseURI $ u ++ escapeURIString isReserved q -command ReloadConfig = loadConfig +command ReloadConfig = updateConfig command Quit = liftIO $ do dir <- getXdgDirectory XdgCache "pancake" exists <- doesDirectoryExist dir @@ -845,6 +269,6 @@ eventLoop = do main :: IO () main = do args <- getArgs - _ <- runStateT (loadConfig >> eventLoop) $ + _ <- runStateT (updateConfig >> eventLoop) $ LS ([],[]) 0 [] def ("--embedded" `elem` args) pure () -- cgit v1.2.3