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

View File

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