xanadu - src/Icons.hs

-rw-r--r-- src/Icons.hs
      1 {-# LANGUAGE OverloadedLabels #-}
      2 {-# LANGUAGE OverloadedStrings #-}
      3 {-# LANGUAGE TypeApplications #-}
      4 
      5 module Icons (
      6     initIcons
      7 ) where
      8 
      9 import Control.Applicative
     10 import Control.Monad.IO.Class (liftIO)
     11 import Control.Monad.Trans.Maybe
     12 import Data.Text (pack)
     13 import System.Directory (doesDirectoryExist, listDirectory, getHomeDirectory)
     14 import System.Environment (lookupEnv)
     15 import System.FilePath ((</>))
     16 import System.IO (hFlush, stdout)
     17 
     18 import Data.GI.Base
     19 import qualified Data.GI.Base.GType as GType
     20 import qualified GI.GdkPixbuf as Pixbuf
     21 import qualified GI.Gio as Gio
     22 import qualified GI.Gtk as Gtk
     23 
     24 initIcons :: Gtk.ApplicationWindow -> IO ()
     25 initIcons win = do
     26     pixbufGType <- glibType @Pixbuf.Pixbuf
     27     listStore <- Gtk.listStoreNew [GType.gtypeString, pixbufGType]
     28     iconTheme <- Gtk.iconThemeGetForScreen =<< Gtk.windowGetScreen win
     29     root <- getRoot
     30     populate listStore iconTheme root
     31     iconView <- new Gtk.IconView
     32         [ #model := listStore
     33         , #selectionMode := Gtk.SelectionModeMultiple
     34         , #textColumn := 0
     35         , #tooltipColumn := 0
     36         , #pixbufColumn := 1
     37         , #reorderable := True
     38         , #itemOrientation := Gtk.OrientationVertical
     39         , #activateOnSingleClick := True
     40         ]
     41     on iconView #itemActivated $ onItemActivated listStore root
     42     Gtk.containerAdd win iconView
     43     return ()
     44 
     45 -- Root folder is $(XDG_DESKTOP_DIR:-$HOME/Desktop)
     46 getRoot :: IO FilePath
     47 getRoot = do
     48     fromEnv <- lookupEnv "XDG_DESKTOP_DIR"
     49     case fromEnv of
     50         Nothing -> (<> "/Desktop") <$> getHomeDirectory
     51         Just "" -> (<> "/Desktop") <$> getHomeDirectory
     52         Just path -> return path
     53 
     54 populate :: Gtk.ListStore -> Gtk.IconTheme -> FilePath -> IO ()
     55 populate listStore iconTheme root = mconcat . map (addItem listStore iconTheme) =<< getItems root
     56 
     57 addItem :: Gtk.ListStore -> Gtk.IconTheme -> Item -> IO ()
     58 addItem listStore iconTheme item = do
     59     iter <- Gtk.listStoreAppend listStore
     60     value <- Gtk.toGValue . Just . itemPath $ item
     61     icon <- runMaybeT $ getIcon iconTheme item
     62     case icon of
     63         Nothing -> Gtk.listStoreSet listStore iter [0] [value]
     64         (Just icon') -> Gtk.listStoreSet listStore iter [0, 1] [value, icon']
     65 
     66 getIcon :: Gtk.IconTheme -> Item -> MaybeT IO GValue
     67 getIcon iconTheme item
     68     | itemIsDir item = liftIO . Gtk.toGValue =<< Gtk.iconThemeLoadIcon iconTheme "folder" 32 []
     69     | otherwise = do
     70         (contentType, _) <- Gio.contentTypeGuess (Just . pack $ itemPath item) Nothing
     71         iconName <- MaybeT . Gio.contentTypeGetGenericIconName $ contentType
     72         liftIO . Gtk.toGValue =<< Gtk.iconThemeLoadIcon iconTheme iconName 32 []
     73 
     74 data Item = Item
     75     { itemPath :: FilePath
     76     , itemIsDir :: Bool
     77     }
     78 
     79 getItems :: FilePath -> IO [Item]
     80 getItems root = do
     81     path <- listDirectory root
     82     isDir <- mapM (doesDirectoryExist . (root </>)) path
     83     return . getZipList $ Item <$> ZipList path <*> ZipList isDir
     84 
     85 onItemActivated :: Gtk.ListStore -> FilePath -> Gtk.TreePath -> IO ()
     86 onItemActivated listStore root treePath = do
     87     (_, iter) <- Gtk.treeModelGetIter listStore treePath
     88     gvalue <- Gtk.treeModelGetValue listStore iter 0
     89     maybeValue <- (Gtk.fromGValue gvalue :: IO (Maybe String))
     90     case maybeValue of
     91         Nothing -> return ()
     92         Just value -> putStrLn (root <> "/" <> value) >> hFlush stdout
     93