1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use <=<" #-}
module Daffm.Configuration where
import Control.Applicative ((<|>))
import Control.Arrow (ArrowChoice (left))
import Control.Exception (throwIO)
import qualified Control.Exception as IO
import Daffm.Action.Commands (parseCommand)
import Daffm.Keymap (parseKeySequence)
import Daffm.Types
import Data.Bifunctor (Bifunctor (first))
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Graphics.Vty as K
import System.Directory (XdgDirectory (XdgConfig), getXdgDirectory)
import System.FilePath (joinPath)
import Toml ((.=))
import qualified Toml
defaultConfiguration :: Configuration
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 '/'], CmdSetCmdline "/"),
([K.KChar 'n'], CmdSearchNext 1),
([K.KChar 'N'], CmdSearchNext (-1)),
([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"),
([K.KChar 'g', K.KChar 'g'], CmdMove $ MoveTo 0),
([K.KChar 'g', K.KChar 'k'], CmdMove $ MoveTo 0),
([K.KChar 'g', K.KChar 'j'], CmdMove MoveToEnd),
([K.KChar 'G'], CmdMove MoveToEnd)
]
getConfigDir :: IO FilePath
getConfigDir = getXdgDirectory XdgConfig "daffm"
getDefaultConfigFilePath :: String -> IO FilePath
getDefaultConfigFilePath "" = do
dir <- getConfigDir
pure $ joinPath [dir, "config.toml"]
getDefaultConfigFilePath name = do
dir <- getConfigDir
pure $ joinPath [dir, "config." <> name <> ".toml"]
resolveConfigPath :: Maybe String -> IO FilePath
resolveConfigPath Nothing = getDefaultConfigFilePath ""
resolveConfigPath (Just ('@' : name)) = getDefaultConfigFilePath name
resolveConfigPath (Just path) = pure path
loadConfigFile :: Maybe String -> IO Configuration
loadConfigFile pathM = do
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
load = (>>= parseWithDefault) . IO.try . Text.readFile
parseWithDefault :: Either IOError Text.Text -> IO Configuration
parseWithDefault rawE = case rawE of
Left _ -> pure defaultConfiguration
Right txt -> (<> defaultConfiguration) <$> parse txt
parse txt = case parseConfig txt of
Left e -> throwIO $ userError $ show e
Right c -> pure c
parseConfig :: Text.Text -> Either Text.Text Configuration
parseConfig = left Toml.prettyTomlDecodeErrors . Toml.decode configurationCodec
configurationCodec :: Toml.TomlCodec Configuration
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
where
keymapRawCodec = Toml.tableMap Toml._KeyText commandCodec
toKeymap = Map.fromList . map (first toKeys) . Map.toList
toKeys = fromMaybe [] . parseKeySequence . stripQuotes
toCmd = fromMaybe CmdNoop . parseCommand
stripQuotes txt = fromMaybe txt (Text.stripPrefix "\"" txt >>= Text.stripSuffix "\"")
commandCodec k = cmdCodec k <|> cmdChainCodec k
cmdCodec = Toml.dimap (const "") toCmd . Toml.text
cmdChainCodec = Toml.dimap (const []) (CmdChain . map toCmd) . Toml.arrayOf Toml._Text
|
