diff --git a/Data/Aeson/Extended.hs b/Data/Aeson/Extended.hs --- a/Data/Aeson/Extended.hs +++ b/Data/Aeson/Extended.hs @@ -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 } diff --git a/Hbro/Bookmarks.hs b/Hbro/Bookmarks.hs --- a/Hbro/Bookmarks.hs +++ b/Hbro/Bookmarks.hs @@ -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 diff --git a/Hbro/Download.hs b/Hbro/Download.hs --- a/Hbro/Download.hs +++ b/Hbro/Download.hs @@ -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 diff --git a/Hbro/History.hs b/Hbro/History.hs --- a/Hbro/History.hs +++ b/Hbro/History.hs @@ -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)) diff --git a/Hbro/Misc.hs b/Hbro/Misc.hs --- a/Hbro/Misc.hs +++ b/Hbro/Misc.hs @@ -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 diff --git a/Hbro/StatusBar.hs b/Hbro/StatusBar.hs --- a/Hbro/StatusBar.hs +++ b/Hbro/StatusBar.hs @@ -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 diff --git a/hbro-contrib.cabal b/hbro-contrib.cabal --- a/hbro-contrib.cabal +++ b/hbro-contrib.cabal @@ -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,