module Vgrep.Environment.Config.Sources.File
( configFromFile
, Attr
, Color
, Style
) where
import Control.Monad ((<=<))
import Control.Monad.IO.Class
import Data.Aeson.Types
( FromJSON (..)
, Options (..)
, camelTo
, defaultOptions
, genericParseJSON
, withObject
, (.!=)
, (.:?)
)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Data.Yaml.Aeson
( decodeFileEither
, prettyPrintParseException
)
import GHC.Generics
import qualified Graphics.Vty.Attributes as Vty
import System.Directory
import System.IO
import Text.Read (readMaybe)
import Vgrep.Command
import Vgrep.Environment.Config.Monoid
import qualified Vgrep.Key as Key
import Vgrep.KeybindingMap
configFromFile :: MonadIO io => io ConfigMonoid
configFromFile = liftIO $ do
configDir <- getAppUserDataDirectory "vgrep"
let configFiles = map (configDir </>)
[ "config.yaml"
, "config.yml"
, "config.json"
, "config" ]
findExistingFile configFiles >>= \case
Nothing -> pure mempty
Just configFile -> decodeFileEither configFile >>= \case
Right config -> pure config
Left err -> do
hPutStrLn stderr $
"Could not parse config file " ++ configFile ++ ":"
++ "\n" ++ prettyPrintParseException err
++ "\nFalling back to default config."
pure mempty
where
findExistingFile :: [FilePath] -> IO (Maybe FilePath)
findExistingFile = \case
[] -> pure Nothing
f : fs -> do
exists <- doesFileExist f
if exists then pure (Just f) else findExistingFile fs
(</>) :: FilePath -> FilePath -> FilePath
dir </> file = dir <> "/" <> file
instance FromJSON ConfigMonoid where
parseJSON = withObject "ConfigMonoid" $ \o -> do
_mcolors <- o .:? "colors" .!= mempty
_mtabstop <- fmap First (o .:? "tabstop")
_meditor <- fmap First (o .:? "editor")
_mkeybindings <- o .:? "keybindings" .!= mempty
pure ConfigMonoid{..}
instance FromJSON ColorsMonoid where
parseJSON = genericParseJSON jsonOptions
instance FromJSON Vty.Attr where
parseJSON = fmap attrToVty . parseJSON
data Attr = Attr
{ foreColor :: Maybe Color
, backColor :: Maybe Color
, style :: Maybe Style
}
deriving (Eq, Show, Generic)
instance FromJSON Attr where
parseJSON = genericParseJSON jsonOptions
attrToVty :: Attr -> Vty.Attr
attrToVty Attr{..} = foldAttrs
[ fmap (flip Vty.withForeColor . colorToVty) foreColor
, fmap (flip Vty.withBackColor . colorToVty) backColor
, fmap (flip Vty.withStyle . styleToVty) style ]
where
foldAttrs = foldr ($) Vty.defAttr . catMaybes
data Color
= Black
| Red
| Green
| Yellow
| Blue
| Magenta
| Cyan
| White
| BrightBlack
| BrightRed
| BrightGreen
| BrightYellow
| BrightBlue
| BrightMagenta
| BrightCyan
| BrightWhite
deriving (Eq, Show, Generic)
instance FromJSON Color where
parseJSON = genericParseJSON jsonOptions
colorToVty :: Color -> Vty.Color
colorToVty = \case
Black -> Vty.black
Red -> Vty.red
Green -> Vty.green
Yellow -> Vty.yellow
Blue -> Vty.blue
Magenta -> Vty.magenta
Cyan -> Vty.cyan
White -> Vty.white
BrightBlack -> Vty.brightBlack
BrightRed -> Vty.brightRed
BrightGreen -> Vty.brightGreen
BrightYellow -> Vty.brightYellow
BrightBlue -> Vty.brightBlue
BrightMagenta -> Vty.brightMagenta
BrightCyan -> Vty.brightCyan
BrightWhite -> Vty.brightWhite
data Style
= Standout
| Underline
| ReverseVideo
| Blink
| Dim
| Bold
deriving (Eq, Show, Generic)
instance FromJSON Style where
parseJSON = genericParseJSON jsonOptions
styleToVty :: Style -> Vty.Style
styleToVty = \case
Standout -> Vty.standout
Underline -> Vty.underline
ReverseVideo -> Vty.reverseVideo
Blink -> Vty.blink
Dim -> Vty.dim
Bold -> Vty.bold
instance FromJSON KeybindingsMonoid where
parseJSON = genericParseJSON jsonOptions
instance FromJSON Command where
parseJSON = genericParseJSON jsonOptions
instance FromJSON KeybindingMap where
parseJSON = fmap KeybindingMap . mapMKeys parseChord <=< parseJSON
mapMKeys :: (Monad m, Ord k') => (k -> m k') -> Map k v -> m (Map k' v)
mapMKeys f = fmap M.fromList . M.foldrWithKey go (pure [])
where
go k x mxs = do
k' <- f k
xs <- mxs
pure ((k', x) : xs)
parseChord :: Monad m => String -> m Key.Chord
parseChord = \case
'C' : '-' : t -> fmap (`Key.withModifier` Key.Ctrl) (parseChord t)
'S' : '-' : t -> fmap (`Key.withModifier` Key.Shift) (parseChord t)
'M' : '-' : t -> fmap (`Key.withModifier` Key.Meta) (parseChord t)
[c] -> pure (Key.key (Key.Char c))
"PgUp" -> pure (Key.key Key.PageUp)
"PgDown" -> pure (Key.key Key.PageDown)
"PgDn" -> pure (Key.key Key.PageDown)
s | Just k <- readMaybe s
-> pure (Key.key k)
| otherwise -> fail ("Unknown key '" <> s <> "'")
jsonOptions :: Options
jsonOptions = defaultOptions
{ constructorTagModifier = camelTo '-'
, fieldLabelModifier = camelTo '-' . stripPrefix }
where
stripPrefix = \case
'_' : 'm' : name -> name
'_' : name -> name
name -> name