Add extend config property to extend configs + move defaults

5 files changed, 65 insertions, 34 deletions

diff --git a/lib/Daffm/Action/Commands.hs b/lib/Daffm/Action/Commands.hs
index 98fec9a..a9cf691 100644
--- a/lib/Daffm/Action/Commands.hs
+++ b/lib/Daffm/Action/Commands.hs
@@ -15,8 +15,6 @@ import Data.Char (isSpace)
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
-import qualified GHC.IO.Handle.Text as Proc
-import System.Process (readProcessWithExitCode)
 import qualified System.Process as Proc
 
 runCmdline :: AppEvent ()
diff --git a/lib/Daffm/Configuration.hs b/lib/Daffm/Configuration.hs
index d3691cd..9536007 100644
--- a/lib/Daffm/Configuration.hs
+++ b/lib/Daffm/Configuration.hs
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use <=<" #-}
 module Daffm.Configuration where
 
 import Control.Applicative ((<|>))
@@ -35,12 +38,21 @@ resolveConfigPath (Just path) = pure path
 
 loadConfigFile :: Maybe String -> IO Configuration
 loadConfigFile pathM = do
-  resolveConfigPath pathM >>= (IO.try . Text.readFile) >>= foobar
+  cfgPath <- resolveConfigPath pathM
+  config <- load cfgPath
+  case configExtend config of
+    Just path -> do
+      baseCfgPath <- resolveConfigPath $ Just $ Text.unpack path
+      if baseCfgPath == cfgPath
+        then pure config
+        else (config <>) <$> load baseCfgPath
+    _ -> pure config
   where
-    foobar :: Either IOError Text.Text -> IO Configuration
-    foobar rawE = case rawE of
+    load = (>>= parseWithDefault) . IO.try . Text.readFile
+    parseWithDefault :: Either IOError Text.Text -> IO Configuration
+    parseWithDefault rawE = case rawE of
       Left _ -> pure defaultConfiguration
-      Right txt -> parse txt
+      Right txt -> (<> defaultConfiguration) <$> parse txt
     parse txt = case parseConfig txt of
       Left e -> throwIO $ userError $ show e
       Right c -> pure c
@@ -53,9 +65,11 @@ configurationCodec =
   Configuration
     <$> (keymapCodec "keymap" .= configKeymap)
     <*> (openerCodec "opener" .= configOpener)
+    <*> (extendCodec "extend" .= configExtend)
     <*> pure Map.empty .= configTheme
   where
     openerCodec = Toml.dioptional . Toml.text
+    extendCodec = Toml.dioptional . Toml.text
 
 keymapCodec :: Toml.Key -> Toml.TomlCodec Keymap
 keymapCodec = Toml.dimap (const Map.empty) toKeymap . keymapRawCodec
diff --git a/lib/Daffm/Keymap.hs b/lib/Daffm/Keymap.hs
index aae4a95..5e5856f 100644
--- a/lib/Daffm/Keymap.hs
+++ b/lib/Daffm/Keymap.hs
@@ -36,7 +36,7 @@ parseKeySequence :: Text.Text -> Maybe [Key]
 parseKeySequence keytxt = parse keytxt []
   where
     parse k keys = case k of
-      (Text.null -> True) -> pure keys
+      "" -> pure keys
       (Text.stripPrefix "<tab>" -> (Just rest')) -> parse rest' $ keys <> [V.KChar '\t']
       (Text.stripPrefix "<space>" -> (Just rest')) -> parse rest' $ keys <> [V.KChar ' ']
       (Text.stripPrefix "<bs>" -> (Just rest')) -> parse rest' $ keys <> [V.KBS]
diff --git a/lib/Daffm/State.hs b/lib/Daffm/State.hs
index 7601acd..210cd8d 100644
--- a/lib/Daffm/State.hs
+++ b/lib/Daffm/State.hs
@@ -13,33 +13,11 @@ import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Zipper.Generic as Zipper
 import qualified Data.Vector as Vec
-import qualified Graphics.Vty as K
 import System.Directory (doesDirectoryExist, doesPathExist, getCurrentDirectory, getHomeDirectory, listDirectory, makeAbsolute, setCurrentDirectory)
-import System.FilePath (joinPath, takeDirectory, takeFileName)
+import System.FilePath (joinPath, takeDirectory)
 import System.PosixCompat (fileExist)
 import qualified System.PosixCompat as Posix
 
-defaultKeymaps :: Keymap
-defaultKeymaps =
-  Map.fromList
-    [ ([K.KChar 'q'], CmdQuit),
-      ([K.KChar 'r', K.KChar 'r'], CmdReload),
-      ([K.KChar '!'], CmdSetCmdline "!"),
-      ([K.KChar ':'], CmdEnterCmdline),
-      ([K.KChar 'l'], CmdOpenSelection),
-      ([K.KChar 'h'], CmdGoBack),
-      ([K.KEnter], CmdOpenSelection),
-      ([K.KBS], CmdGoBack),
-      ([K.KChar 'v'], CmdToggleSelection),
-      ([K.KChar '\t'], CmdToggleSelection),
-      ([K.KChar 'C'], CmdClearSelection),
-      ([K.KChar '~'], CmdChangeDir "~"),
-      ([K.KChar '$'], CmdShell False "$SHELL"),
-      ([K.KChar 'g', K.KChar 'x'], CmdShell False "!xdg-open % >/dev/null 2>&1"),
-      ([K.KChar 'g', K.KChar 'h'], CmdChangeDir "~"),
-      ([K.KChar 'g', K.KChar 'c', K.KChar 'f', K.KChar 'g'], CmdChangeDir "~/.config/daffm")
-    ]
-
 mkEditor :: (Zipper.GenericTextZipper a) => a -> Editor.Editor a FocusTarget
 mkEditor = Editor.editor FocusCmdline (Just 1)
 
@@ -52,7 +30,7 @@ mkEmptyAppState config =
       stateListPositionHistory = Map.empty,
       stateFileSelections = Set.empty,
       stateCwd = "",
-      stateKeyMap = configKeymap config <> defaultKeymaps,
+      stateKeyMap = configKeymap config,
       stateOpenerScript = configOpener config,
       stateKeySequence = []
     }
@@ -82,12 +60,15 @@ stripQuotes txt = fromMaybe txt (double <|> single)
     double = Text.stripPrefix "\"" txt >>= Text.stripSuffix "\""
     single = Text.stripPrefix "'" txt >>= Text.stripSuffix "'"
 
+stripTrailingSlash :: Text.Text -> Text.Text
+stripTrailingSlash path = fromMaybe path $ Text.stripSuffix "/" path
+
 textAsString :: (String -> String) -> Text.Text -> Text.Text
 textAsString f = Text.pack . f . Text.unpack
 
 loadDirToState :: FilePathText -> AppState -> IO AppState
 loadDirToState dir' appState@(AppState {stateCwd, stateListPositionHistory}) = do
-  normalizedDir <- (normalizePath . stripQuotes . trim) dir' >>= withCwdFallback
+  normalizedDir <- (normalizePath . stripTrailingSlash . stripQuotes . trim) dir' >>= withCwdFallback
   stat <- Posix.getSymbolicLinkStatus $ Text.unpack normalizedDir
   let (dir, targetFilePathM) =
         if Posix.isDirectory stat
diff --git a/lib/Daffm/Types.hs b/lib/Daffm/Types.hs
index 5133c2b..eb9d9a5 100644
--- a/lib/Daffm/Types.hs
+++ b/lib/Daffm/Types.hs
@@ -3,9 +3,11 @@ module Daffm.Types where
 import Brick (EventM)
 import qualified Brick.Widgets.Edit as Editor
 import qualified Brick.Widgets.List as L
+import Control.Applicative ((<|>))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
+import qualified Graphics.Vty as K
 import qualified Graphics.Vty as V
 import System.Posix.Types (FileMode, FileOffset)
 
@@ -78,10 +80,46 @@ type KeySequence = [Key]
 
 data Configuration = Configuration
   { configKeymap :: !Keymap,
-    configOpener :: Maybe Text.Text,
+    configOpener :: !(Maybe Text.Text),
+    configExtend :: !(Maybe Text.Text),
     configTheme :: !(Map.Map Text.Text Text.Text)
   }
   deriving (Show)
 
+instance Semigroup Configuration where
+  a <> b =
+    a
+      { configKeymap = configKeymap a <> configKeymap b,
+        configOpener = configOpener a <|> configOpener b,
+        configTheme = configTheme a <> configTheme b
+      }
+
 defaultConfiguration :: Configuration
-defaultConfiguration = Configuration {configKeymap = Map.empty, configOpener = Nothing, configTheme = Map.empty}
+defaultConfiguration =
+  Configuration
+    { configKeymap = defaultKeymaps,
+      configOpener = Nothing,
+      configTheme = Map.empty,
+      configExtend = Nothing
+    }
+
+defaultKeymaps :: Keymap
+defaultKeymaps =
+  Map.fromList
+    [ ([K.KChar 'q'], CmdQuit),
+      ([K.KChar 'r', K.KChar 'r'], CmdReload),
+      ([K.KChar '!'], CmdSetCmdline "!"),
+      ([K.KChar ':'], CmdEnterCmdline),
+      ([K.KChar 'l'], CmdOpenSelection),
+      ([K.KChar 'h'], CmdGoBack),
+      ([K.KEnter], CmdOpenSelection),
+      ([K.KBS], CmdGoBack),
+      ([K.KChar 'v'], CmdToggleSelection),
+      ([K.KChar '\t'], CmdToggleSelection),
+      ([K.KChar 'C'], CmdClearSelection),
+      ([K.KChar '~'], CmdChangeDir "~"),
+      ([K.KChar '$'], CmdShell False "$SHELL"),
+      ([K.KChar 'g', K.KChar 'x'], CmdShell False "!xdg-open % >/dev/null 2>&1"),
+      ([K.KChar 'g', K.KChar 'h'], CmdChangeDir "~"),
+      ([K.KChar 'g', K.KChar 'c', K.KChar 'f', K.KChar 'g'], CmdChangeDir "~/.config/daffm")
+    ]