REF remove partial lists from dev
This commit is contained in:
parent
49c3947b5a
commit
1e54682f1c
|
|
@ -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,10 +139,9 @@ getGroups = do
|
|||
actions <- sequence [getStaticActions, getRemovableActions, getMTPActions]
|
||||
return $
|
||||
(++ [metaActions]) $
|
||||
mapMaybe mkGroup $
|
||||
L.groupBy (\(hx, _) (hy, _) -> hx == hy) $
|
||||
L.sortBy (\(hx, _) (hy, _) -> compare hx hy) $
|
||||
concat actions
|
||||
fmap mkGroup $
|
||||
NE.groupAllWith fst $
|
||||
concat actions
|
||||
where
|
||||
metaActions =
|
||||
titledGroup "Meta Actions" $
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue