.stylish-haskell.yaml

@@ -0,0 +1,357 @@
+# stylish-haskell configuration file
+# ==================================
+
+# The stylish-haskell tool is mainly configured by specifying steps. These steps
+# are a list, so they have an order, and one specific step may appear more than
+# once (if needed). Each file is processed by these steps in the given order.
+steps:
+  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
+  # by default.
+  # - unicode_syntax:
+  #     # In order to make this work, we also need to insert the UnicodeSyntax
+  #     # language pragma. If this flag is set to true, we insert it when it's
+  #     # not already present. You may want to disable it if you configure
+  #     # language extensions using some other method than pragmas. Default:
+  #     # true.
+  #     add_language_pragma: true
+
+  # Format module header
+  #
+  # Currently, this option is not configurable and will format all exports and
+  # module declarations to minimize diffs
+  #
+  # - module_header:
+  #     # How many spaces use for indentation in the module header.
+  #     indent: 4
+  #
+  #     # Should export lists be sorted?  Sorting is only performed within the
+  #     # export section, as delineated by Haddock comments.
+  #     sort: true
+  #
+  #     # See `separate_lists` for the `imports` step.
+  #     separate_lists: true
+
+  # Format record definitions. This is disabled by default.
+  #
+  # You can control the layout of record fields. The only rules that can't be configured
+  # are these:
+  #
+  # - "|" is always aligned with "="
+  # - "," in fields is always aligned with "{"
+  # - "}" is likewise always aligned with "{"
+  #
+  # - records:
+  #     # How to format equals sign between type constructor and data constructor.
+  #     # Possible values:
+  #     # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor.
+  #     # - "indent N" -- insert a new line and N spaces from the beginning of the next line.
+  #     equals: "indent 2"
+  #
+  #     # How to format first field of each record constructor.
+  #     # Possible values:
+  #     # - "same_line" -- "{" and first field goes on the same line as the data constructor.
+  #     # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor
+  #     first_field: "indent 2"
+  #
+  #     # How many spaces to insert between the column with "," and the beginning of the comment in the next line.
+  #     field_comment: 2
+  #
+  #     # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.
+  #     deriving: 2
+  #
+  #     # How many spaces to insert before "via" clause counted from indentation of deriving clause
+  #     # Possible values:
+  #     # - "same_line" -- "via" part goes on the same line as "deriving" keyword.
+  #     # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword.
+  #     via: "indent 2"
+  #
+  #     # Sort typeclass names in the "deriving" list alphabetically.
+  #     sort_deriving: true
+  #
+  #     # Wheter or not to break enums onto several lines
+  #     #
+  #     # Default: false
+  #     break_enums: false
+  #
+  #     # Whether or not to break single constructor data types before `=` sign
+  #     #
+  #     # Default: true
+  #     break_single_constructors: true
+  #
+  #     # Whether or not to curry constraints on function.
+  #     #
+  #     # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@
+  #     #
+  #     # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@
+  #     #
+  #     # Default: false
+  #     curried_context: false
+
+  # Align the right hand side of some elements.  This is quite conservative
+  # and only applies to statements where each element occupies a single
+  # line.
+  # Possible values:
+  # - always - Always align statements.
+  # - adjacent - Align statements that are on adjacent lines in groups.
+  # - never - Never align statements.
+  # All default to always.
+  - simple_align:
+      cases: always
+      top_level_patterns: always
+      records: always
+      multi_way_if: always
+
+  # Import cleanup
+  - imports:
+      # There are different ways we can align names and lists.
+      #
+      # - global: Align the import names and import list throughout the entire
+      #   file.
+      #
+      # - file: Like global, but don't add padding when there are no qualified
+      #   imports in the file.
+      #
+      # - group: Only align the imports per group (a group is formed by adjacent
+      #   import lines).
+      #
+      # - none: Do not perform any alignment.
+      #
+      # Default: global.
+      align: global
+
+      # The following options affect only import list alignment.
+      #
+      # List align has following options:
+      #
+      # - after_alias: Import list is aligned with end of import including
+      #   'as' and 'hiding' keywords.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                          init, last, length)
+      #
+      # - with_alias: Import list is aligned with start of alias or hiding.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                 init, last, length)
+      #
+      # - with_module_name: Import list is aligned `list_padding` spaces after
+      #   the module name.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #                          init, last, length)
+      #
+      #   This is mainly intended for use with `pad_module_names: false`.
+      #
+      #   > import qualified Data.List as List (concat, foldl, foldr, head,
+      #                          init, last, length, scanl, scanr, take, drop,
+      #                          sort, nub)
+      #
+      # - new_line: Import list starts always on new line.
+      #
+      #   > import qualified Data.List      as List
+      #   >     (concat, foldl, foldr, head, init, last, length)
+      #
+      # - repeat: Repeat the module name to align the import list.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head)
+      #   > import qualified Data.List      as List (init, last, length)
+      #
+      # Default: after_alias
+      list_align: after_alias
+
+      # Right-pad the module names to align imports in a group:
+      #
+      # - true: a little more readable
+      #
+      #   > import qualified Data.List       as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # - false: diff-safe
+      #
+      #   > import qualified Data.List as List (concat, foldl, foldr, init,
+      #   >                                     last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # Default: true
+      pad_module_names: true
+
+      # Long list align style takes effect when import is too long. This is
+      # determined by 'columns' setting.
+      #
+      # - inline: This option will put as much specs on same line as possible.
+      #
+      # - new_line: Import list will start on new line.
+      #
+      # - new_line_multiline: Import list will start on new line when it's
+      #   short enough to fit to single line. Otherwise it'll be multiline.
+      #
+      # - multiline: One line per import list entry.
+      #   Type with constructor list acts like single import.
+      #
+      #   > import qualified Data.Map as M
+      #   >     ( empty
+      #   >     , singleton
+      #   >     , ...
+      #   >     , delete
+      #   >     )
+      #
+      # Default: inline
+      long_list_align: multiline
+
+      # Align empty list (importing instances)
+      #
+      # Empty list align has following options
+      #
+      # - inherit: inherit list_align setting
+      #
+      # - right_after: () is right after the module name:
+      #
+      #   > import Vector.Instances ()
+      #
+      # Default: inherit
+      empty_list_align: inherit
+
+      # List padding determines indentation of import list on lines after import.
+      # This option affects 'long_list_align'.
+      #
+      # - <integer>: constant value
+      #
+      # - module_name: align under start of module name.
+      #   Useful for 'file' and 'group' align settings.
+      #
+      # Default: 4
+      list_padding: 4
+
+      # Separate lists option affects formatting of import list for type
+      # or class. The only difference is single space between type and list
+      # of constructors, selectors and class functions.
+      #
+      # - true: There is single space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
+      #
+      # - false: There is no space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
+      #
+      # Default: true
+      separate_lists: true
+
+      # Space surround option affects formatting of import lists on a single
+      # line. The only difference is single space after the initial
+      # parenthesis and a single space before the terminal parenthesis.
+      #
+      # - true: There is single space associated with the enclosing
+      #   parenthesis.
+      #
+      #   > import Data.Foo ( foo )
+      #
+      # - false: There is no space associated with the enclosing parenthesis
+      #
+      #   > import Data.Foo (foo)
+      #
+      # Default: false
+      space_surround: false
+
+      # Enabling this argument will use the new GHC lib parse to format imports.
+      #
+      # This currently assumes a few things, it will assume that you want post
+      # qualified imports. It is also not as feature complete as the old
+      # imports formatting.
+      #
+      # It does not remove redundant lines or merge lines. As such, the full
+      # feature scope is still pending.
+      #
+      # It _is_ however, a fine alternative if you are using features that are
+      # not parseable by haskell src extensions and you're comfortable with the
+      # presets.
+      #
+      # Default: false
+      ghc_lib_parser: false
+
+  # Language pragmas
+  - language_pragmas:
+      # We can generate different styles of language pragma lists.
+      #
+      # - vertical: Vertical-spaced language pragmas, one per line.
+      #
+      # - compact: A more compact style.
+      #
+      # - compact_line: Similar to compact, but wrap each line with
+      #   `{-#LANGUAGE #-}'.
+      #
+      # Default: vertical.
+      style: vertical
+
+      # Align affects alignment of closing pragma brackets.
+      #
+      # - true: Brackets are aligned in same column.
+      #
+      # - false: Brackets are not aligned together. There is only one space
+      #   between actual import and closing bracket.
+      #
+      # Default: true
+      align: true
+
+      # stylish-haskell can detect redundancy of some language pragmas. If this
+      # is set to true, it will remove those redundant pragmas. Default: true.
+      remove_redundant: true
+
+      # Language prefix to be used for pragma declaration, this allows you to
+      # use other options non case-sensitive like "language" or "Language".
+      # If a non correct String is provided, it will default to: LANGUAGE.
+      language_prefix: LANGUAGE
+
+  # Replace tabs by spaces. This is disabled by default.
+  # - tabs:
+  #     # Number of spaces to use for each tab. Default: 8, as specified by the
+  #     # Haskell report.
+  #     spaces: 8
+
+  # Remove trailing whitespace
+  - trailing_whitespace: {}
+
+  # Squash multiple spaces between the left and right hand sides of some
+  # elements into single spaces. Basically, this undoes the effect of
+  # simple_align but is a bit less conservative.
+  # - squash: {}
+
+# A common setting is the number of columns (parts of) code will be wrapped
+# to. Different steps take this into account.
+#
+# Set this to null to disable all line wrapping.
+#
+# Default: 80.
+columns: 80
+
+# By default, line endings are converted according to the OS. You can override
+# preferred format here.
+#
+# - native: Native newline format. CRLF on Windows, LF on other OSes.
+#
+# - lf: Convert to LF ("\n").
+#
+# - crlf: Convert to CRLF ("\r\n").
+#
+# Default: native.
+newline: native
+
+# Sometimes, language extensions are specified in a cabal file or from the
+# command line instead of using language pragmas in the file. stylish-haskell
+# needs to be aware of these, so it can parse the file correctly.
+#
+# No language extensions are enabled by default.
+# language_extensions:
+  # - TemplateHaskell
+  # - QuasiQuotes
+
+# Attempt to find the cabal file in ancestors of the current directory, and
+# parse options (currently only language extensions) from that.
+#
+# Default: true
+cabal: true

app/rofi-dev.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE OverloadedStrings  #-}
 
 --------------------------------------------------------------------------------
--- rofi-dev - a rofi prompt for mountable devices
+-- | rofi-dev - a rofi prompt for mountable devices
 --
 -- Like all "mount helpers" this is basically a wrapper for low-level utilities
 -- the mount things from the command line. It also creates/destroys mountpoint
@@ -14,9 +14,11 @@
 module Main (main) where
 
 import           Bitwarden.Internal
+
 import           Control.Lens
 import           Control.Monad
 import           Control.Monad.Reader
+
 import           Data.List
 import           Data.List.Split       (splitOn)
 import qualified Data.Map              as M
@@ -24,16 +26,21 @@ import Data.Maybe
 import qualified Data.Text             as T
 import           Data.Typeable
 import qualified Data.Vector           as V
+
 import           Dhall                 hiding (maybe, sequence, void)
 import qualified Dhall.Map             as DM
+
 import           Rofi.Command
+
+import           Text.Printf
+
 import           System.Console.GetOpt
 import           System.Directory
 import           System.Environment
 import           System.FilePath.Posix
 import           System.Posix.User     (getEffectiveUserName)
 import           System.Process
-import Text.Printf
+
 import           UnliftIO.Exception
 
 main :: IO ()
@@ -45,8 +52,7 @@ parse args = case getOpt Permute options args of
   (_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options
   where
     h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
-    defaultOpts r =
+    defaultOpts r = Opts
-      Opts
       { optsConfig = Nothing
       , optsAlias = Nothing
       , optsUnmount = False
@@ -55,20 +61,13 @@ parse args = case getOpt Permute options args of
 
 options :: [OptDescr (Opts -> Opts)]
 options =
-  [ Option
+  [ Option ['c'] ["config"]
-      ['c']
+    (ReqArg (\s m -> m { optsConfig = Just s } ) "CONF")
-      ["config"]
-      (ReqArg (\s m -> m {optsConfig = Just s}) "CONF")
     "The path to the config file"
-  , Option
+  , Option ['m'] ["mount"]
-      ['m']
+    (ReqArg (\s m -> m { optsAlias = Just s } ) "ALIAS")
-      ["mount"]
-      (ReqArg (\s m -> m {optsAlias = Just s}) "ALIAS")
     "Mount the device specified by ALIAS directly"
-  , Option
+  , Option ['u'] ["unmount"] (NoArg (\m -> m { optsUnmount = True } ))
-      ['u']
-      ["unmount"]
-      (NoArg (\m -> m {optsUnmount = True}))
     "Unmount the device specified by ALIAS instead of mounting it."
   ]
 
@@ -77,11 +76,10 @@ data Opts = Opts
   , optsAlias    :: Maybe String
   , optsUnmount  :: Bool
   , optsRofiArgs :: [String]
-  }
+  } deriving Show
-  deriving (Show)
 
 --------------------------------------------------------------------------------
--- Main prompt
+-- | Main prompt
 --
 -- This command will have one Rofi prompt and will display all available
 -- mounts grouped by device type (eg removable, sshfs, cifs, etc). I like
@@ -94,8 +92,7 @@ runMounts opts = do
   let tmpPath = fromMaybe defaultTmpPath $ scTmpPath =<< static
   let staticDevs = maybe M.empty scDevices static
   let verbose = fromMaybe False $ scVerbose =<< static
-  let mountconf =
+  let mountconf = MountConf
-        MountConf
         { mountconfVolatilePath = tmpPath
         , mountconfRofiArgs = optsRofiArgs opts
         , mountconfStaticDevs = staticDevs
@@ -113,9 +110,7 @@ parseStaticConfig p = do
     Right c -> return $ Just (c :: StaticConfig)
   where
     es = over substitutions (DM.union vars) defaultEvaluateSettings
-    vars =
+    vars = DM.fromList $ catMaybes
-      DM.fromList $
-        catMaybes
       [ toVar (auto :: Decoder TreeConfig)
       , toVar (auto :: Decoder DeviceConfig)
       , toVar (auto :: Decoder DataConfig)
@@ -129,17 +124,11 @@ parseStaticConfig p = do
       , toVar (auto :: Decoder BitwardenConfig)
       , toVar (auto :: Decoder MountConfig)
       ]
-    toVar a =
+    toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a))
-      fmap (\n -> (T.pack $ show n, maximum $ expected a)) $
+      $ listToMaybe $ snd $ splitTyConApp $ typeOf a
-        listToMaybe $
-          snd $
-            splitTyConApp $
-              typeOf a
 
 runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
-runPrompt gs =
+runPrompt gs = selectAction $ emptyMenu
-  selectAction $
-    emptyMenu
                { groups = gs
                , prompt = Just "Select Device"
                }
@@ -147,26 +136,10 @@ runPrompt gs =
 getGroups :: RofiMountIO [RofiGroup MountConf]
 getGroups = do
   actions <- sequence [getStaticActions, getRemovableActions, getMTPActions]
-  return $
+  return $ mapMaybe mkGroup
-    (++ [metaActions]) $
+    $ groupBy (\(hx, _) (hy, _) -> hx == hy)
-      mapMaybe mkGroup $
+    $ sortBy (\(hx, _) (hy, _) -> compare hx hy)
-        groupBy (\(hx, _) (hy, _) -> hx == hy) $
+    $ concat actions
-          sortBy (\(hx, _) (hy, _) -> compare hx hy) $
-            concat actions
-  where
-    metaActions =
-      titledGroup "Meta Actions" $
-        toRofiActions [("  Dismount All", dismountAll)]
-
-dismountAll :: RofiMountIO ()
-dismountAll = do
-  umount =<< asks (configToTree' . mountconfStaticDevs)
-  umount =<< getRemovableDevices
-  umount =<< getMTPDevices
-  return ()
-  where
-    umount :: Mountable a => [a] -> RofiMountIO ()
-    umount = mapM_ (`mountMaybe` True)
 
 mountByAlias :: Bool -> String -> RofiMountIO ()
 mountByAlias unmountFlag alias = do
@@ -175,9 +148,8 @@ mountByAlias unmountFlag alias = do
 
 mkGroup :: [(Header, ProtoAction [String])] -> Maybe (RofiGroup MountConf)
 mkGroup [] = Nothing
-mkGroup as =
+mkGroup as = let ((h, _):_) = as in
-  let ((h, _) : _) = as
+  Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as
-   in Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as
 
 alignSep :: String
 alignSep = " | "
@@ -186,8 +158,7 @@ alignEntries :: [ProtoAction [String]] -> [(String, RofiMountIO ())]
 alignEntries ps = zip (align es) as
   where
     (es, as) = unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
-    align =
+    align = fmap (intercalate alignSep)
-      fmap (intercalate alignSep)
       . transpose
       . mapToLast pad
       . transpose
@@ -195,24 +166,23 @@ alignEntries ps = zip (align es) as
     getMax = maximum . fmap length
     mapToLast _ []     = []
     mapToLast _ [x]    = [x]
-    mapToLast f (x : xs) = f x : mapToLast f xs
+    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
 
 data MountConf = MountConf
   { mountconfVolatilePath :: FilePath
   , mountconfRofiArgs     :: [String]
   , mountconfStaticDevs   :: M.Map String TreeConfig
   , mountconfVerbose      :: Bool
-  }
+  } deriving Show
-  deriving (Show)
 
 instance RofiConf MountConf where
-  defArgs MountConf {mountconfRofiArgs = a} = a
+  defArgs MountConf { mountconfRofiArgs = a } = a
 
 --------------------------------------------------------------------------------
--- Mountable typeclass
+-- | Mountable typeclass
 --
 -- Class to provide common interface for anything that can be mounted.
 
@@ -249,7 +219,7 @@ class Mountable a where
   mountState :: a -> RofiMountIO MountState
 
 --------------------------------------------------------------------------------
--- Actionable typeclass
+-- | Actionable typeclass
 --
 -- Class to provide common interface for anything that can be presented in the
 -- Rofi menu as an action. Note that this must be separate from the Mountable
@@ -273,7 +243,7 @@ class Mountable a => Actionable a where
     let h = groupHeader dev
     let action = when i $ mountMaybe dev $ mountedState m
     let entry = case fmtEntry dev of
-          (e : es) -> (mountedPrefix m i ++ e) : es
+              (e:es) -> (mountedPrefix m i ++ e):es
               _      -> []
     return (h, ProtoAction entry action)
     where
@@ -282,17 +252,13 @@ class Mountable a => Actionable a where
       mountedPrefix Mounted True   = "* "
       mountedPrefix Partial True   = "- "
 
-mountableToAction
+mountableToAction :: Actionable a => RofiMountIO [a] -> RofiMountIO [(Header, ProtoAction [String])]
-  :: Actionable a
-  => RofiMountIO [a]
-  -> RofiMountIO [(Header, ProtoAction [String])]
 mountableToAction ms = mapM mkAction =<< ms
 
 type RofiMountIO a = RofiIO MountConf a
 
 -- headers appear in the order listed here (per Enum)
-data Header
+data Header = CIFSHeader
-  = CIFSHeader
   | SSHFSHeader
   | VeracryptHeader
   | RemovableHeader
@@ -315,30 +281,27 @@ instance Ord Header where
 data ProtoAction a = ProtoAction a (RofiMountIO ())
 
 --------------------------------------------------------------------------------
--- Static device configuration (dhall)
+-- | Static device configuration (dhall)
 
 data MountConfig = MountConfig
   { mpPath  :: FilePath
   , mpLabel :: Maybe String
-  }
+  } deriving (Show, Generic, FromDhall)
-  deriving (Show, Generic, FromDhall)
 
 data BitwardenConfig = BitwardenConfig
   { bwKey   :: String
-  , bwTries :: Integer
+  , bwTries :: Integer }
-  }
   deriving (Show, Generic, FromDhall)
 
 newtype SecretConfig = SecretConfig
-  {secretAttributes :: M.Map String String}
+  { secretAttributes :: M.Map String String }
   deriving (Show, Generic, FromDhall)
 
 newtype PromptConfig = PromptConfig
-  {promptTries :: Integer}
+  { promptTries :: Integer }
   deriving (Show, Generic, FromDhall)
 
-data PasswordConfig
+data PasswordConfig = PwdBW BitwardenConfig
-  = PwdBW BitwardenConfig
   | PwdLS SecretConfig
   | PwdPr PromptConfig
   deriving (Show, Generic, FromDhall)
@@ -349,11 +312,9 @@ data CIFSOpts = CIFSOpts
   , cifsoptsUID       :: Maybe Integer
   , cifsoptsGID       :: Maybe Integer
   , cifsoptsIocharset :: Maybe String
-  }
+  } deriving (Show, Generic, FromDhall)
-  deriving (Show, Generic, FromDhall)
 
-data DataConfig
+data DataConfig = VeracryptConfig VeracryptData
-  = VeracryptConfig VeracryptData
   | SSHFSConfig SSHFSData
   | CIFSConfig CIFSData
   deriving (Show, Generic, FromDhall)
@@ -361,45 +322,39 @@ data DataConfig
 data VeracryptData = VeracryptData
   { vcVolume   :: String
   , vcPassword :: Maybe PasswordConfig
-  }
+  } deriving (Show, Generic, FromDhall)
-  deriving (Show, Generic, FromDhall)
 
 data SSHFSData = SSHFSData
   { sshfsRemote   :: String
   , sshfsPassword :: Maybe PasswordConfig
-  }
+  } deriving (Show, Generic, FromDhall)
-  deriving (Show, Generic, FromDhall)
 
 data CIFSData = CIFSData
   { cifsRemote   :: String
   , cifsSudo     :: Bool
   , cifsPassword :: Maybe PasswordConfig
   , cifsOpts     :: Maybe CIFSOpts
-  }
+  } deriving (Show, Generic, FromDhall)
-  deriving (Show, Generic, FromDhall)
 
 data DeviceConfig = DeviceConfig
   { deviceMount :: MountConfig
   , deviceData  :: DataConfig
-  }
+  } deriving (Show, Generic, FromDhall)
-  deriving (Show, Generic, FromDhall)
 
 data TreeConfig = TreeConfig
   { tcParent   :: DeviceConfig
   , tcChildren :: V.Vector String
-  }
+  } deriving (Show, Generic, FromDhall)
-  deriving (Show, Generic, FromDhall)
 
 data StaticConfig = StaticConfig
   { scTmpPath :: Maybe String
   , scVerbose :: Maybe Bool
   , scDevices :: M.Map String TreeConfig
-  }
+  } deriving (Show, Generic, FromDhall)
-  deriving (Show, Generic, FromDhall)
 
 --------------------------------------------------------------------------------
--- Static devices trees
+-- | Static devices trees
-
+--
 -- Static devices as defined in the config file may declare dependencies on
 -- other static devices, and thus are best represented as a tree. Note that the
 -- tree is both Actionable and Mountable, where each node in the tree is only
@@ -423,29 +378,29 @@ 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 (CIFSConfig (CIFSData { cifsRemote = r }))         = r
-      target (SSHFSConfig (SSHFSData {sshfsRemote = r})) = r
+      target (SSHFSConfig (SSHFSData { sshfsRemote = r }))      = r
-      target (VeracryptConfig (VeracryptData {vcVolume = v})) = v
+      target (VeracryptConfig (VeracryptData { vcVolume = v })) = v
 
-  groupHeader (Tree DeviceConfig {deviceData = d} _) =
+  groupHeader (Tree DeviceConfig{ deviceData = d } _) =
     case d of
-      CIFSConfig {} -> CIFSHeader
+      CIFSConfig{}      -> CIFSHeader
-      SSHFSConfig {} -> SSHFSHeader
+      SSHFSConfig{}     -> SSHFSHeader
-      VeracryptConfig {} -> VeracryptHeader
+      VeracryptConfig{} -> VeracryptHeader
 
 configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
 configToTree' devMap = configToTree devMap <$> M.elems devMap
 
 configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree
-configToTree devMap TreeConfig {tcParent = p, tcChildren = c} =
+configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } =
   Tree p $ fmap go V.toList c
   where
     go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds
 
 --------------------------------------------------------------------------------
--- Static devices
+-- | Static devices
 --
 -- This is complex because there may be multiple classes of static devices
 -- in the config file, and each device may depend on another device that is
@@ -455,56 +410,50 @@ configToTree devMap TreeConfig {tcParent = p, tcChildren = c} =
 -- outside of these needs to be aware of these different classes.
 
 instance Mountable DeviceConfig where
-  mount DeviceConfig {deviceMount = m, deviceData = devData} False = do
+  mount DeviceConfig{ deviceMount = m, deviceData = devData} False = do
     m' <- getAbsMountpoint m
-    withTmpMountDir m' $
+    withTmpMountDir m'
-      io $
+      $ io
-        case devData of
+      $ case devData of
-          SSHFSConfig (SSHFSData {sshfsRemote = r, sshfsPassword = p}) ->
+          SSHFSConfig (SSHFSData { sshfsRemote = r, sshfsPassword = p }) ->
             mountSSHFS m' p r
-          CIFSConfig
+          CIFSConfig (CIFSData
-            ( CIFSData
                       { cifsRemote = r
                       , cifsSudo = s
                       , cifsPassword = p
                       , cifsOpts = o
-                }
+                      }) ->
-              ) ->
             mountCIFS s r m' o p
-          VeracryptConfig
+          VeracryptConfig (VeracryptData
-            ( VeracryptData
                            { vcPassword = p
                            , vcVolume = v
-                }
+                           }) ->
-              ) ->
             mountVeracrypt m' p v
-  mount DeviceConfig {deviceMount = m, deviceData = d} True = do
+
+  mount DeviceConfig{ deviceMount = m, deviceData = d } True = do
     m' <- getAbsMountpoint m
     runAndRemoveDir m' $ io $ case d of
-      CIFSConfig (CIFSData {cifsSudo = s}) -> runMountSudoMaybe s "umount" [m']
+      CIFSConfig (CIFSData { cifsSudo = s }) -> runMountSudoMaybe s "umount" [m']
       VeracryptConfig _          -> runVeraCrypt ["-d", m'] ""
       _                          -> runMount "umount" [m'] ""
 
-  allInstalled DeviceConfig {deviceData = devData} =
+  allInstalled DeviceConfig{ deviceData = devData } = io $ isJust
-    io $
-      isJust
     <$> findExecutable (exe devData)
     where
-      exe SSHFSConfig {} = "sshfs"
+      exe SSHFSConfig{}     = "sshfs"
-      exe CIFSConfig {} = "mount.cifs"
+      exe CIFSConfig{}      = "mount.cifs"
-      exe VeracryptConfig {} = "veracrypt"
+      exe VeracryptConfig{} = "veracrypt"
 
-  mountState DeviceConfig {deviceMount = m, deviceData = d} = do
+  mountState DeviceConfig{ deviceMount = m, deviceData = d } = do
   -- mountState DeviceConfig{ deviceMount = m } = do
     case d of
-      VeracryptConfig {} -> veracryptMountState m
+      VeracryptConfig{} -> veracryptMountState m
       _                 -> do
         b <- (io . isDirMounted) =<< getAbsMountpoint m
         return $ if b then Mounted else Unmounted
 
-  getLabel
+  getLabel DeviceConfig
-    DeviceConfig
+    { deviceMount = MountConfig { mpPath = p, mpLabel = l }
-      { deviceMount = MountConfig {mpPath = p, mpLabel = l}
     } = fromMaybe (takeFileName p) l
 
 mountSSHFS :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
@@ -513,13 +462,8 @@ mountSSHFS mountpoint pwdConfig remote =
   where
     run other = runMount "sshfs" (other ++ [remote, mountpoint])
 
-mountCIFS
+mountCIFS :: Bool -> String -> FilePath -> Maybe CIFSOpts
-  :: Bool
+  -> Maybe PasswordConfig -> IO MountResult
-  -> String
-  -> FilePath
-  -> Maybe CIFSOpts
-  -> Maybe PasswordConfig
-  -> IO MountResult
 mountCIFS useSudo remote mountpoint opts pwdConfig =
   withPasswordGetter pwdConfig runPwd run
   where
@@ -530,8 +474,7 @@ mountCIFS useSudo remote mountpoint opts pwdConfig =
 fromCIFSOpts :: CIFSOpts -> String
 fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
   where
-    fs =
+    fs = [ ("username", cifsoptsUsername)
-      [ ("username", cifsoptsUsername)
          , ("workgroup", cifsoptsWorkgroup)
          , ("uid", fmap show . cifsoptsUID)
          , ("gid", fmap show .  cifsoptsGID)
@@ -541,8 +484,8 @@ fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
 
 mountVeracrypt :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
 mountVeracrypt mountpoint pwdConfig volume =
-  withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"])) $
+  withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"]))
-    runVeraCrypt args ""
+  $ runVeraCrypt args ""
   where
     args = [volume, mountpoint]
 
@@ -567,36 +510,35 @@ veracryptMountState mc = do
     auxPath = fmap (\i -> "/tmp/.veracrypt_aux_mnt" ++ [i]) . vcIndex
     vcIndex spec = case reverse spec of
       -- TODO what if I have more than one digit?
-      (i : _) -> if i `elem` ['0' .. '9'] then Just i else Nothing
+      (i:_) -> if i `elem` ['0'..'9'] then Just i else Nothing
       _     -> Nothing
 
 getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
-getAbsMountpoint MountConfig {mpPath = m} =
+getAbsMountpoint MountConfig{ mpPath = m } =
   asks $ flip appendRoot m . mountconfVolatilePath
 
 getStaticActions :: RofiMountIO [(Header, ProtoAction [String])]
 getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
 
 --------------------------------------------------------------------------------
--- Password-getting functions for static devices
+-- | Password-getting functions for static devices
 
 type PasswordGetter = IO (Maybe String)
 
 runSecret :: M.Map String String -> PasswordGetter
-runSecret kvs = readCmdSuccess "secret-tool" ("lookup" : kvs') ""
+runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
   where
     kvs' = concatMap (\(k, v) -> [k, v]) $ M.toList kvs
 
 runBitwarden :: String -> PasswordGetter
-runBitwarden pname =
+runBitwarden pname = ((password . login) <=< find (\i -> name i == pname))
-  ((password . login) <=< find (\i -> name i == pname))
   <$> getItems
 
 runPromptLoop :: Integer -> PasswordGetter -> PasswordGetter
 runPromptLoop n pwd = do
   res <- pwd
-  if isNothing res
+  if isNothing res then
-    then if n <= 0 then return Nothing else runPromptLoop (n - 1) pwd
+    if n <= 0 then return Nothing else runPromptLoop (n-1) pwd
     else return res
 
 -- configToPwd :: PasswordConfig -> PasswordGetter
@@ -615,23 +557,20 @@ runPromptLoop n pwd = do
 --     runMaybe x y = (\r -> if isNothing r then y else return r) =<< x
 
 configToPwd :: PasswordConfig -> PasswordGetter
-configToPwd (PwdBW (BitwardenConfig {bwKey = k, bwTries = n})) =
+configToPwd (PwdBW (BitwardenConfig { bwKey = k, bwTries = n })) =
   runPromptLoop n $ runBitwarden k
 configToPwd (PwdLS s) = runSecret $ secretAttributes s
 configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
 
-withPasswordGetter
+withPasswordGetter :: Maybe PasswordConfig -> (String -> IO MountResult)
-  :: Maybe PasswordConfig
+  -> IO MountResult -> IO MountResult
-  -> (String -> IO MountResult)
-  -> IO MountResult
-  -> IO MountResult
 withPasswordGetter (Just pwdConfig) runPwd _ =
   maybe (return $ MountError "Password could not be obtained") runPwd
   =<< configToPwd pwdConfig
 withPasswordGetter Nothing _ run = run
 
 --------------------------------------------------------------------------------
--- Removable devices
+-- | Removable devices
 --
 -- A device which can be removed (such as a flash drive). These are distinct
 -- from any device in the static configuration in that they only have device
@@ -644,21 +583,21 @@ data Removable = Removable
     deriving (Eq, Show)
 
 instance Mountable Removable where
-  mount Removable {removablePath = d} m =
+  mount Removable { removablePath = d } m =
     io $ runMount "udisksctl" [c, "-b", d] ""
     where
       c = if m then "unmount" else "mount"
 
   allInstalled _ = fmap isJust $ io $ findExecutable "udisksctl"
 
-  mountState Removable {removablePath = d} = do
+  mountState Removable { removablePath = d } = do
     s <- elem d <$> io curDeviceSpecs
     return $ if s then Mounted else Unmounted
 
-  getLabel Removable {removableLabel = l} = l
+  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
 
@@ -668,24 +607,23 @@ instance Actionable Removable where
 -- label shown on the prompt will be 'SIZE Volume' where size is the size of
 -- the device
 getRemovableDevices :: RofiConf c => RofiIO c [Removable]
-getRemovableDevices =
+getRemovableDevices = fromLines toDev . lines
-  fromLines toDev . lines
   <$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "")
   where
     columns = "FSTYPE,HOTPLUG,PATH,LABEL,SIZE"
     -- can't use 'words' here since it will drop spaces in the front
     toDev line = case splitBy ' ' line of
-      ("" : _) -> Nothing
+      ("":_)             -> Nothing
       [_, "1", d, "", s] -> mk d $ s ++ " Volume"
       [_, "1", d, l, _]  -> mk d l
       _                  -> Nothing
-    mk d l = Just $ Removable {removablePath = d, removableLabel = l}
+    mk d l = Just $ Removable { removablePath = d, removableLabel = l }
 
 getRemovableActions :: RofiMountIO [(Header, ProtoAction [String])]
 getRemovableActions = mountableToAction getRemovableDevices
 
 --------------------------------------------------------------------------------
--- MTP devices
+-- | MTP devices
 
 mtpExe :: String
 mtpExe = "jmtpfs"
@@ -699,17 +637,18 @@ data MTPFS = MTPFS
     deriving (Eq, Show)
 
 instance Mountable MTPFS where
-  mount MTPFS {mtpfsBus = b, mtpfsDevice = n, mtpfsMountpoint = m} False = do
+  mount MTPFS { mtpfsBus = b, mtpfsDevice = n, mtpfsMountpoint = m } False = do
     -- TODO add autodismount to options
     let dev = "-device=" ++ b ++ "," ++ n
     withTmpMountDir m $ io $ runMount mtpExe [dev, m] ""
-  mount MTPFS {mtpfsMountpoint = m} True =
+
+  mount MTPFS { mtpfsMountpoint = m } True =
     runAndRemoveDir m $ io $ runMount "umount" [m] ""
 
-  -- \| return True always since the list won't even show without jmtpfs
+  -- | return True always since the list won't even show without jmtpfs
   allInstalled _ = return True
 
-  mountState MTPFS {mtpfsMountpoint = m} = do
+  mountState MTPFS { mtpfsMountpoint = m } = do
     s <- io $ isDirMounted m
     return $ if s then Mounted else Unmounted
 
@@ -725,16 +664,13 @@ getMTPDevices = do
       dir <- asks mountconfVolatilePath
       res <- io $ readProcess mtpExe ["-l"] ""
       return $ fromLines (toDev dir) $ toDevList res
-    toDevList =
+    toDevList = reverse
-      reverse
       . takeWhile (not . isPrefixOf "Available devices")
       . reverse
       . lines
     toDev dir s = case splitOn ", " s of
-      [busNum, devNum, _, _, desc, vendor] ->
+      [busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc]
-        let d = unwords [vendor, desc]
+        in Just $ MTPFS
-         in Just $
-              MTPFS
            { mtpfsBus = busNum
            , mtpfsDevice = devNum
            , mtpfsMountpoint = dir </> canonicalize d
@@ -759,7 +695,7 @@ instance Actionable MTPFS where
   groupHeader _ = MTPFSHeader
 
 --------------------------------------------------------------------------------
--- Notifications
+-- | Notifications
 
 data NotifyIcon = IconError | IconInfo
 
@@ -775,15 +711,13 @@ notifyMountResult mounted label result = case result of
     verb = if mounted then "unmount" else "mount" :: String
 
 notify :: NotifyIcon -> String -> Maybe String -> IO ()
-notify icon summary body =
+notify icon summary body = void $ spawnProcess "notify-send"
-  void $
+  $ maybe args (\b -> args ++ [b]) body
-    spawnProcess "notify-send" $
-      maybe args (\b -> args ++ [b]) body
   where
     args = ["-i", show icon, summary]
 
 --------------------------------------------------------------------------------
--- Mount commands
+-- | Mount commands
 
 data MountResult = MountSuccess | MountError String deriving (Show, Eq)
 
@@ -791,8 +725,7 @@ runMount :: String -> [String] -> String -> IO MountResult
 runMount cmd args stdin = eitherToMountResult <$> readCmdEither cmd args stdin
 
 runMount' :: String -> [String] -> String -> [(String, String)] -> IO MountResult
-runMount' cmd args stdin environ =
+runMount' cmd args stdin environ = eitherToMountResult
-  eitherToMountResult
   <$> readCmdEither' cmd args stdin environ
 
 runMountSudoMaybe :: Bool -> String -> [String] -> IO MountResult
@@ -800,8 +733,7 @@ runMountSudoMaybe useSudo cmd args =
   runMountSudoMaybe' useSudo cmd args []
 
 runMountSudoMaybe' :: Bool -> String -> [String] -> [(String, String)] -> IO MountResult
-runMountSudoMaybe' useSudo cmd args environ =
+runMountSudoMaybe' useSudo cmd args environ = maybe
-  maybe
   (runMount' cmd args "" environ)
   (\r -> runSudoMount' r cmd args environ)
   =<< if useSudo then readPassword' "Sudo Password" else return Nothing
@@ -821,7 +753,7 @@ eitherToMountResult (Right _) = MountSuccess
 eitherToMountResult (Left (_, _, e)) = MountError e
 
 --------------------------------------------------------------------------------
--- Low-level mount functions
+-- | Low-level mount functions
 
 mountMap :: IO (M.Map FilePath String)
 mountMap = do
@@ -857,8 +789,7 @@ rmDirOnMountError d f = do
 -- | Run a mount command and create the mountpoint if it does not exist, and
 -- remove the mountpoint if a mount error occurs
 withTmpMountDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
-withTmpMountDir m =
+withTmpMountDir m = rmDirOnMountError m
-  rmDirOnMountError m
   . bracketOnError_ (mkDirMaybe m) (rmDirMaybe m)
 
 -- | Run an unmount command and remove the mountpoint if no errors occur
@@ -872,10 +803,8 @@ mkDirMaybe :: FilePath -> RofiMountIO ()
 mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp
 
 rmDirMaybe :: FilePath -> RofiMountIO ()
-rmDirMaybe fp =
+rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp
-  whenInMountDir fp $
+  $ asks mountconfVolatilePath >>= io . rmUntil fp
-    unlessMountpoint fp $
-      asks mountconfVolatilePath >>= io . rmUntil fp
   where
     rmUntil cur target = unless (target == cur) $ do
       removePathForcibly cur
@@ -895,7 +824,7 @@ isDirMounted :: FilePath -> IO Bool
 isDirMounted fp = elem fp <$> curMountpoints
 
 --------------------------------------------------------------------------------
--- Other functions
+-- | Other functions
 
 fromLines :: (String -> Maybe a) -> [String] -> [a]
 fromLines f = mapMaybe (f . stripWS)
@@ -905,9 +834,8 @@ splitBy :: Char -> String -> [String]
 splitBy delimiter = foldr f [[]]
   where
     f _ [] = []
-    f c l@(x : xs)
+    f c l@(x:xs) | c == delimiter = []:l
-      | c == delimiter = [] : l
+                 | otherwise = (c:x):xs
-      | otherwise = (c : x) : xs
 
 appendRoot :: FilePath -> FilePath -> FilePath
 appendRoot root path = if isRelative path then root </> path else path

fourmolu.yaml

@@ -1,14 +0,0 @@
-indentation: 2
-function-arrows: leading
-comma-style: leading
-import-export-style: leading
-indent-wheres: true
-record-brace-space: true
-newlines-between-decls: 1
-haddock-style: single-line
-haddock-style-module:
-let-style: inline
-in-style: right-align
-respectful: false
-fixities: []
-unicode: never