hbro-contrib 1.5.0.0 → 1.6.0.0
raw patch · 7 files changed
+64/−50 lines, 7 filesdep +chunked-datadep +filepathdep +mono-traversabledep −classy-preludedep ~hbro
Dependencies added: chunked-data, filepath, mono-traversable, safe-exceptions
Dependencies removed: classy-prelude
Dependency ranges changed: hbro
Files
- Data/Aeson/Extended.hs +5/−6
- Hbro/Bookmarks.hs +16/−12
- Hbro/Download.hs +7/−5
- Hbro/History.hs +16/−13
- Hbro/Misc.hs +5/−2
- Hbro/StatusBar.hs +9/−9
- hbro-contrib.cabal +6/−3
Data/Aeson/Extended.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-} module Data.Aeson.Extended (module X, module Data.Aeson.Extended) where -- {{{ Imports-import ClassyPrelude+import Control.Exception.Safe+import Control.Monad (MonadPlus(..)) import Data.Aeson as X import Data.Aeson.Encode.Pretty as X@@ -13,11 +13,10 @@ import Network.URI -- }}} -data JsonException = UnableDecode String deriving(Eq)+data JsonException = UnableDecode String deriving(Eq, Show) -instance Exception JsonException-instance Show JsonException where- show (UnableDecode s) = s+instance Exception JsonException where+ displayException (UnableDecode s) = s -- | Trivial wrapper around 'URI', used to avoid orphan instances. newtype WrappedURI = WrappedURI { unwrapURI :: URI }
Hbro/Bookmarks.hs view
@@ -23,6 +23,9 @@ import Hbro.Misc import Data.Aeson.Extended+import Data.Containers+import Data.IOData+import Data.Set (Set) import qualified Data.Set as Set -- import Data.Random.Extras -- import Data.Random.RVar@@ -33,6 +36,7 @@ import Safe import System.Directory+import System.FilePath -- }}} -- {{{ Type definitions@@ -45,7 +49,7 @@ deriving instance Ord Entry instance Describable Entry where- describe (Entry uri tags) = unwords $ map (\x -> "[" ++ x ++ "]") (Set.toList tags) ++ [tshow uri]+ describe (Entry uri tags) = unwords $ map (\x -> "[" <> x <> "]") (Set.toList tags) <> [show uri] instance FromJSON Entry where parseJSON (Object v) = Entry <$> (unwrapURI <$> v .: "uri") <*> v .: "tags"@@ -64,22 +68,22 @@ hasTag tag = member tag . _tags -- | Add current webpage to bookmarks with given tags-addCurrent :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadThrow m, Alternative m) => [Text] -> m ()+addCurrent :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadCatch m, Alternative m) => [Text] -> m () addCurrent tags = (`addCurrent'` tags) =<< getBookmarksFile -- | Like 'add', but you can specify the bookmarks file path-addCurrent' :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadThrow m, Alternative m) => FilePath -> [Text] -> m ()+addCurrent' :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadCatch m, Alternative m) => FilePath -> [Text] -> m () addCurrent' file tags = do uri <- getCurrentURI void . add file $ Entry uri (Set.fromList tags) -- | Add a custom entry to bookmarks-add :: (ControlIO m, MonadLogger m, MonadThrow m, Alternative m)+add :: (ControlIO m, MonadLogger m, MonadCatch m, Alternative m) => FilePath -- ^ Bookmarks file -> Entry -- ^ Custom bookmark entry -> m () add file newEntry = do- info $ "New bookmark: " ++ describe newEntry+ info $ "New bookmark: " <> describe newEntry tryIO . io . copyFile file $ file <.> "bak" entries <- (decodeM =<< readFile file) <|> return Set.empty writeFile file . encodePretty $ Set.insert newEntry entries@@ -104,11 +108,11 @@ selectByTag' file dmenuOptions = do -- Read bookmarks file entries <- decodeM =<< readFile file- let tags = unlines . Set.toList . foldl' Set.union Set.empty $ map _tags entries+ let tags = unlines . Set.toList . foldr Set.union Set.empty $ map _tags entries -- Let user select a tag tag <- dmenu dmenuOptions tags- debug $ "User selected tag " ++ tag+ debug $ "User selected tag " <> tag return . map _uri $ filter (hasTag tag) entries --popOldest :: PortableFilePath -> Text -> IO (Maybe URI)@@ -128,26 +132,26 @@ -- forM_ selection $ \s -> do -- (newLines, value) <- runRVar s DevURandom --- renameFile file' (file' ++ ".old")+-- renameFile file' (file' <> ".old") -- writeFile file' . unlines . ordNub $ newLines -- return . parseURIReference . last . words $ value -- | Remove all bookmarks entries matching the given tag.-deleteByTag :: (ControlIO m, MonadLogger m, MonadThrow m) => m ()+deleteByTag :: (ControlIO m, MonadLogger m, MonadCatch m) => m () deleteByTag = (`deleteByTag'` defaultDmenuOptions) =<< getBookmarksFile -- | Like 'selectByTag', but you can specify the bookmarks file path-deleteByTag' :: (ControlIO m, MonadLogger m, MonadThrow m)+deleteByTag' :: (ControlIO m, MonadLogger m, MonadCatch m) => FilePath -- ^ Bookmarks' database file -> [Text] -- ^ dmenu's commandline options -> m () deleteByTag' file dmenuOptions = do entries <- decodeM =<< readFile file- let tags = unlines . Set.toList . foldl' Set.union Set.empty . map _tags $ Set.toList entries+ let tags = unlines . Set.toList . foldr Set.union Set.empty . map _tags $ Set.toList entries tag <- dmenu dmenuOptions tags- info $ "Deleting bookmarks with tag " ++ tag+ info $ "Deleting bookmarks with tag " <> tag tryIO . io . copyFile file $ file <.> "bak" writeFile file . encodePretty $ Set.filter (not . hasTag tag) entries
Hbro/Download.hs view
@@ -6,31 +6,33 @@ module Hbro.Download where -- {{{ Imports+import Hbro.Error import Hbro.Prelude import Network.URI +import System.FilePath import System.Process -- }}} -aria, wget, axel :: (ControlIO m)+aria, wget, axel :: (ControlIO m, MonadCatch m) => FilePath -- ^ Destination directory -> URI -- ^ URI to download -> Text -- ^ Destination file name -> m ()-aria (pack -> destination) (tshow -> uri) outputFile+aria (pack -> destination) (show -> uri) outputFile = downloadWith "aria2c" [uri, "-d", destination, "-o", outputFile, "-q"] outputFile -wget destination (tshow -> uri) outputFile+wget destination (show -> uri) outputFile = downloadWith "wget" [uri, "-O", dest] outputFile where dest = pack (destination </> unpack outputFile) -axel destination (tshow -> uri) outputFile+axel destination (show -> uri) outputFile = downloadWith "axel" [uri, "-o", dest] outputFile where dest = pack (destination </> unpack outputFile) -downloadWith :: (ControlIO m) => Text -> [Text] -> Text -> m ()+downloadWith :: (ControlIO m, MonadCatch m) => Text -> [Text] -> Text -> m () downloadWith (unpack -> program) (map unpack -> args) (unpack -> outputFile) = handleIO (io . print) . io $ do callProcess "notify-send" ["Download started", outputFile] callProcess program args
Hbro/History.hs view
@@ -17,17 +17,21 @@ ) where -- {{{ Imports-import Hbro+import Hbro hiding(log) import Hbro.Logger import Hbro.Misc import Data.Aeson.Extended+import Data.IOData import qualified Data.Set as Set import Data.Time import Network.URI import System.Directory+import System.FilePath++import Text.Read -- }}} -- {{{ Type definitions@@ -44,7 +48,7 @@ | otherwise = compare t t' instance Describable Entry where- describe (Entry time uri title) = unwords [pack (formatTime defaultTimeLocale dateFormat time), tshow uri, title]+ describe (Entry time uri title) = unwords [pack (formatTime defaultTimeLocale dateFormat time), show uri, title] instance FromJSON Entry where parseJSON (Object v) = Entry <$> v .: "time" <*> (unwrapURI <$> v .: "uri") <*> v .: "title"@@ -53,11 +57,10 @@ instance ToJSON Entry where toJSON (Entry time uri title) = object ["time" .= time, "uri" .= WrappedURI uri, "title" .= title] -data HistoryException = InvalidSelection deriving(Eq)+data HistoryException = InvalidSelection deriving(Eq, Show) -instance Exception HistoryException-instance Show HistoryException where- show InvalidSelection = "Invalid history item selected."+instance Exception HistoryException where+ displayException InvalidSelection = "Invalid history item selected." -- }}} dateFormat :: String@@ -67,11 +70,11 @@ getHistoryFile = getAppUserDataDirectory "hbro" >/> "history" -- | Log current visited page to history database-log :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadThrow m, Alternative m) => m ()+log :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadCatch m, Alternative m) => m () log = log' =<< getHistoryFile -- | Like 'log', but you can specify the history file path-log' :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadThrow m, Alternative m) => FilePath -> m ()+log' :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadCatch m, Alternative m) => FilePath -> m () log' file = do uri <- getCurrentURI title <- getPageTitle@@ -80,13 +83,13 @@ add' file (Entry now uri title) -- | Add a new entry to history database-add :: (ControlIO m, MonadLogger m, MonadThrow m, Alternative m) => Entry -> m ()+add :: (ControlIO m, MonadLogger m, MonadCatch m, Alternative m) => Entry -> m () add newEntry = (`add'` newEntry) =<< getHistoryFile -- | Like 'add', but you can specify the history file path-add' :: (ControlIO m, MonadLogger m, MonadThrow m, Alternative m) => FilePath -> Entry -> m ()+add' :: (ControlIO m, MonadLogger m, MonadCatch m, Alternative m) => FilePath -> Entry -> m () add' file newEntry = do- debug $ "Adding new entry <" ++ tshow (_uri newEntry) ++ "> to history file <" ++ pack file ++ ">"+ debug $ "Adding new entry <" <> show (_uri newEntry) <> "> to history file <" <> pack file <> ">" tryIO . io . copyFile file $ file <.> "bak" entries <- (decodeM =<< readFile file) <|> return Set.empty @@ -100,5 +103,5 @@ select' :: (ControlIO m, MonadThrow m) => FilePath -> [Text] -> m Entry select' file dmenuOptions = do entries <- zip [1..] . sortBy (flip (comparing _time)) <$> (decodeM =<< readFile file)- result <- dmenu dmenuOptions . unlines $ map (\(i :: Int, e :: Entry) -> tshow i ++ " " ++ describe e) entries- maybe (throwM InvalidSelection) return ((`lookup` entries) =<< readMay =<< headMay (words result))+ result <- dmenu dmenuOptions . unlines $ map (\(i :: Int, e :: Entry) -> show i <> " " <> describe e) entries+ maybe (throwM InvalidSelection) return ((`lookup` entries) =<< readMaybe . unpack =<< headMay (words result))
Hbro/Misc.hs view
@@ -7,6 +7,8 @@ -- {{{ Imports import Hbro +import Data.IOData+ import Graphics.UI.Gtk.WebKit.WebBackForwardList import Graphics.UI.Gtk.WebKit.WebHistoryItem import Graphics.UI.Gtk.WebKit.WebView@@ -15,13 +17,14 @@ import Safe +import System.IO (hClose) import System.Process -- }}} -- | Open dmenu with given input and return selected entry. -- This will block effectively the current thread.-dmenu :: (ControlIO m, MonadThrow m)+dmenu :: (ControlIO m) => [Text] -- ^ dmenu's commandline options -> Text -- ^ dmenu's input -> m Text -- ^ Selected entry@@ -66,5 +69,5 @@ title <- webHistoryItemGetTitle item uri <- webHistoryItemGetUri item case uri of- Just u -> return $ Just (u ++ " | " ++ fromMaybe "Untitled" title)+ Just u -> return $ Just (u <> " | " <> fromMaybe "Untitled" title) _ -> return Nothing
Hbro/StatusBar.hs view
@@ -41,10 +41,10 @@ page <- get adjustment adjustmentPageSize case upper-lower-page of- 0 -> gAsync $ labelSetText widget (asText "ALL")+ 0 -> gAsync $ labelSetText widget ("ALL" :: Text) x -> gAsync . labelSetText widget $ show ((round $ current/x*100) :: Int) ++ "%" - gAsync $ labelSetText widget (asText "0%")+ gAsync $ labelSetText widget ("0%" :: Text) -- | /!\\ Doesn't work for now. -- Write current zoom level in the given Label.@@ -54,7 +54,7 @@ mainView <- ask getWebView >>= \w -> get w webViewZoomLevel >>= updateZoomLabel void $ addHandler (mainView^.zoomLevelChangedHandler_) updateZoomLabel- where updateZoomLabel = gAsync . labelSetMarkup widget . escapeMarkup . show+ where updateZoomLabel a = gAsync $ labelSetMarkup widget $ escapeMarkup $ (show a :: Text) -- | Write current keystrokes state in the given 'Label'@@ -68,25 +68,25 @@ -- | Write current load progress in the given 'Label'.-installProgressWidget :: (ControlIO m, MonadLogger m, MonadResource m, MonadReader r m, Has MainView r) => Label -> m ()+installProgressWidget :: (ControlIO m, MonadResource m, MonadReader r m, Has MainView r) => Label -> m () installProgressWidget widget = do mainView <- ask -- Load started addHandler (mainView^.loadStartedHandler_) $ \_ -> gAsync $ do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = red}]- labelSetText widget (asText "0%")+ labelSetText widget ("0%" :: Text) -- Progress changed addHandler (mainView^.progressChangedHandler_) $ \progress -> gAsync $ do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = yellow}]- labelSetText widget $ tshow progress ++ "%"+ labelSetText widget $ (show progress <> "%" :: Text) -- Load finished addHandler (mainView^.loadFinishedHandler_) $ \_ -> gAsync $ do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = green}]- labelSetText widget (asText "100%")+ labelSetText widget ("100%" :: Text) -- Error addHandler (mainView^.loadFailedHandler_) $ \(_uri, _e) -> gAsync $ do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = red}]- labelSetText widget $ asText "100%"+ labelSetText widget $ ("100%" :: Text) return () @@ -130,7 +130,7 @@ , AttrForeground{ paStart = i+2+j+k+l, paEnd = -1, paColor = mFragment colors } ] - labelSetText widget (show uri)+ labelSetText widget (show uri :: Text) data URIColors = URIColors
hbro-contrib.cabal view
@@ -1,5 +1,5 @@ Name: hbro-contrib-Version: 1.5.0.0+Version: 1.6.0.0 Synopsis: Third-party extensions to hbro. Description: Cf README Homepage: https://github.com/k0ral/hbro-contrib@@ -26,14 +26,16 @@ aeson-pretty, base == 4.*, bytestring,- classy-prelude >= 0.9.4,+ chunked-data, containers, directory,+ filepath, glib, gtk3 >= 0.12.3,- hbro >= 1.5,+ hbro >= 1.6, lens, monad-control,+ mono-traversable, mtl, network-uri, pango,@@ -43,6 +45,7 @@ -- random-fu, resourcet, safe,+ safe-exceptions, -- taggy-lens, text, time,