ndwarshuis
/
rofi-extras
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF remove partial lists from dev

This commit is contained in:
Nathan Dwarshuis 2023-02-14 23:09:12 -05:00
parent 49c3947b5a
commit 1e54682f1c
1 changed files with 41 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
app/rofi-dev.hs
View File

@ -18,8 +18,8 @@ import Dhall.TH
import RIO import RIO
import RIO.Directory import RIO.Directory
import qualified RIO.List as L import qualified RIO.List as L
import qualified RIO.List.Partial as LP
import qualified RIO.Map as M import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T import qualified RIO.Text as T
import Rofi.Command import Rofi.Command
import System.Console.GetOpt import System.Console.GetOpt
@ -139,9 +139,8 @@ getGroups = do
actions <- sequence [getStaticActions, getRemovableActions, getMTPActions] actions <- sequence [getStaticActions, getRemovableActions, getMTPActions]
return $ return $
(++ [metaActions]) $ (++ [metaActions]) $
mapMaybe mkGroup $ fmap mkGroup $
L.groupBy (\(hx, _) (hy, _) -> hx == hy) $ NE.groupAllWith fst $
L.sortBy (\(hx, _) (hy, _) -> compare hx hy) $
concat actions concat actions
where where
metaActions = metaActions =
@ -163,30 +162,38 @@ mountByAlias unmountFlag alias = do
static <- asks mountconfStaticDevs static <- asks mountconfStaticDevs
mapM_ (`mountMaybe` unmountFlag) $ configToTree static <$> M.lookup alias static mapM_ (`mountMaybe` unmountFlag) $ configToTree static <$> M.lookup alias static
mkGroup :: [(Header, ProtoAction [T.Text])] -> Maybe (RofiGroup MountConf) mkGroup :: NE.NonEmpty (Header, ProtoAction) -> RofiGroup MountConf
mkGroup [] = Nothing
mkGroup as = mkGroup as =
let ((h, _) : _) = as let (h, _) = NE.head as
in Just $ titledGroup (T.pack $ show h) $ toRofiActions $ alignEntries $ fmap snd as in titledGroup (T.pack $ show h) $ toRofiActions $ NE.toList $ alignEntries $ fmap snd as
alignSep :: T.Text alignSep :: T.Text
alignSep = " | " alignSep = " | "
alignEntries :: [ProtoAction [T.Text]] -> [(T.Text, RofiMountIO ())] alignEntries :: NE.NonEmpty (ProtoAction) -> NE.NonEmpty (T.Text, RofiMountIO ())
alignEntries ps = zip (align es) as alignEntries ps = NE.zip (align es) as
where where
(es, as) = L.unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps (es, as) = NE.unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
align = align =
fmap (T.intercalate alignSep) fmap (T.intercalate alignSep . NE.toList)
. L.transpose . NE.transpose
. mapToLast pad . fmap padAll
. L.transpose -- . mapToLast pad
-- TODO not DRY (this is just a pad operation) . NE.transpose
pad xs = let m = getMax xs in fmap (\x -> T.append x (T.replicate (m - T.length x) " ")) xs -- padAll xs = let
getMax = LP.maximum . fmap T.length padAll xs = let m = maxNE $ fmap T.length xs in fmap (rpad m ' ') xs
mapToLast _ [] = [] maxNE (x :| []) = x
mapToLast _ [x] = [x] maxNE (x :| (y : ys)) = maxNE $ (max x y) :| ys
mapToLast f (x : xs) = f x : mapToLast f xs
-- pad xs = let m = getMax xs in fmap (\x -> T.append x (T.replicate (m - T.length x) " ")) xs
-- getMax = LP.maximum . fmap T.length
rpad :: Int -> Char -> T.Text -> T.Text
rpad n c s = T.append s $ T.replicate (n - T.length s) $ T.singleton c
-- mapToLast _ [] = []
-- mapToLast _ [x] = [x]
-- mapToLast f (x : xs) = f x : mapToLast f xs
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Global config used in the reader monad stack -- Global config used in the reader monad stack
@ -251,22 +258,21 @@ class Mountable a where
class Mountable a => Actionable a where class Mountable a => Actionable a where
-- | Return a string to go in the Rofi menu for the given type -- | Return a string to go in the Rofi menu for the given type
fmtEntry :: a -> [T.Text] fmtEntry :: a -> NE.NonEmpty T.Text
fmtEntry d = [getLabel d] fmtEntry d = (getLabel d :| [])
groupHeader :: a -> Header groupHeader :: a -> Header
-- | Given a mountable type, return a rofi action (string to go in the -- | Given a mountable type, return a rofi action (string to go in the
-- Rofi prompt and an action to perform when it is selected) -- Rofi prompt and an action to perform when it is selected)
mkAction :: a -> RofiMountIO (Header, ProtoAction [T.Text]) mkAction :: a -> RofiMountIO (Header, ProtoAction)
mkAction dev = do mkAction dev = do
m <- mountState dev m <- mountState dev
i <- allInstalled dev i <- allInstalled dev
let h = groupHeader dev let h = groupHeader dev
let action = when i $ mountMaybe dev $ mountedState m let action = when i $ mountMaybe dev $ mountedState m
let entry = case fmtEntry dev of let entry = case fmtEntry dev of
(e : es) -> (T.append (mountedPrefix m i) e) : es (e :| es) -> (T.append (mountedPrefix m i) e) :| es
_ -> []
return (h, ProtoAction entry action) return (h, ProtoAction entry action)
where where
mountedPrefix _ False = "! " mountedPrefix _ False = "! "
@ -277,7 +283,7 @@ class Mountable a => Actionable a where
mountableToAction mountableToAction
:: Actionable a :: Actionable a
=> RofiMountIO [a] => RofiMountIO [a]
-> RofiMountIO [(Header, ProtoAction [T.Text])] -> RofiMountIO [(Header, ProtoAction)]
mountableToAction ms = mapM mkAction =<< ms mountableToAction ms = mapM mkAction =<< ms
type RofiMountIO a = RIO MountConf a type RofiMountIO a = RIO MountConf a
@ -304,7 +310,7 @@ instance Show Header where
instance Ord Header where instance Ord Header where
compare x y = compare (fromEnum x) (fromEnum y) compare x y = compare (fromEnum x) (fromEnum y)
data ProtoAction a = ProtoAction a (RofiMountIO ()) data ProtoAction = ProtoAction (NE.NonEmpty T.Text) (RofiMountIO ())
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Static devices trees -- Static devices trees
@ -332,7 +338,7 @@ instance Mountable a => Mountable (Tree a) where
getLabel (Tree p _) = getLabel p getLabel (Tree p _) = getLabel p
instance Actionable (Tree DeviceConfig) where instance Actionable (Tree DeviceConfig) where
fmtEntry (Tree p@DeviceConfig {deviceData = d} _) = [getLabel p, target d] fmtEntry (Tree p@DeviceConfig {deviceData = d} _) = (getLabel p :| [target d])
where where
target (CIFSConfig (CIFSData {cifsRemote = r})) = r target (CIFSConfig (CIFSData {cifsRemote = r})) = r
target (SSHFSConfig (SSHFSData {sshfsRemote = r})) = r target (SSHFSConfig (SSHFSData {sshfsRemote = r})) = r
@ -484,7 +490,7 @@ getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
getAbsMountpoint MountConfig {mpPath = m} = getAbsMountpoint MountConfig {mpPath = m} =
asks $ flip appendRoot (T.unpack m) . mountconfVolatilePath asks $ flip appendRoot (T.unpack m) . mountconfVolatilePath
getStaticActions :: RofiMountIO [(Header, ProtoAction [T.Text])] getStaticActions :: RofiMountIO [(Header, ProtoAction)]
getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -568,7 +574,7 @@ instance Mountable Removable where
getLabel Removable {removableLabel = l} = l getLabel Removable {removableLabel = l} = l
instance Actionable Removable where instance Actionable Removable where
fmtEntry Removable {removablePath = d, removableLabel = l} = [l, d] fmtEntry Removable {removablePath = d, removableLabel = l} = (l :| [d])
groupHeader _ = RemovableHeader groupHeader _ = RemovableHeader
@ -591,7 +597,7 @@ getRemovableDevices =
_ -> Nothing _ -> Nothing
mk d l = Just $ Removable {removablePath = d, removableLabel = l} mk d l = Just $ Removable {removablePath = d, removableLabel = l}
getRemovableActions :: RofiMountIO [(Header, ProtoAction [T.Text])] getRemovableActions :: RofiMountIO [(Header, ProtoAction)]
getRemovableActions = mountableToAction getRemovableDevices getRemovableActions = mountableToAction getRemovableDevices
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -657,14 +663,14 @@ getMTPDevices = do
| c == ' ' = Just '-' | c == ' ' = Just '-'
| otherwise = Just c | otherwise = Just c
getMTPActions :: RofiMountIO [(Header, ProtoAction [T.Text])] getMTPActions :: RofiMountIO [(Header, ProtoAction)]
getMTPActions = mountableToAction getMTPDevices getMTPActions = mountableToAction getMTPDevices
mtpExeInstalled :: IO Bool mtpExeInstalled :: IO Bool
mtpExeInstalled = isJust <$> findExecutable mtpExe mtpExeInstalled = isJust <$> findExecutable mtpExe
instance Actionable MTPFS where instance Actionable MTPFS where
fmtEntry d = [getLabel d] fmtEntry d = (getLabel d :| [])
groupHeader _ = MTPFSHeader groupHeader _ = MTPFSHeader