{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of camelTo
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

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 (..)
    , Parser
    , 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

-- $setup
-- >>> import Data.Either (isLeft)
-- >>> import Data.Yaml.Aeson (decodeEither', ParseException(..))


{- |
Reads the configuration from a JSON or YAML file. The file should be
located in one of the following places:

* @~\/.vgrep\/config.yaml@,
* @~\/.vgrep\/config.yml@,
* @~\/.vgrep\/config.json@ or
* @~\/.vgrep\/config@.

When none of these files exist, no error is raised. When a file exists, but
cannot be parsed, a warning is written to stderr.

Supported formats are JSON and YAML. The example YAML config given in the
project directory (@config.yaml.example@) is equivalent to the default
config:

>>> import qualified Vgrep.Environment.Config as C
>>> Right config <- decodeFileEither "config.yaml.example" :: IO (Either ParseException ConfigMonoid)
>>> C.fromConfigMonoid config == C.defaultConfig
True

Example YAML config file for 'Vgrep.Environment.Config.defaultConfig':

> colors:
>   line-numbers:
>     fore-color: blue
>   line-numbers-hl:
>     fore-color: blue
>     style: bold
>   normal: {}
>   normal-hl:
>     style: bold
>   file-headers:
>     back-color: green
>   selected:
>     style: standout
> tabstop: 8
> editor: "vi"

Example JSON file for the same config:

> {
>   "colors": {
>     "line-numbers" : {
>       "fore-color": "blue"
>     },
>     "line-numbers-hl": {
>       "fore-color": "blue",
>       "style": "bold"
>     },
>     "normal": {},
>     "normal-hl": {
>       "style": "bold"
>     },
>     "file-headers": {
>       "back-color": "green"
>     },
>     "selected": {
>       "style": "standout"
>     }
>   },
>   "tabstop": 8,
>   "editor": "vi"
> }

The JSON/YAML keys correspond to the lenses in "Vgrep.Environment.Config",
the values for 'Vty.Color' and 'Vty.Style' can be obtained from the
corresponding predefined constants in "Graphics.Vty.Attributes".
-}
configFromFile :: MonadIO io => io ConfigMonoid
configFromFile :: io ConfigMonoid
configFromFile = IO ConfigMonoid -> io ConfigMonoid
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ConfigMonoid -> io ConfigMonoid)
-> IO ConfigMonoid -> io ConfigMonoid
forall a b. (a -> b) -> a -> b
$ do
    FilePath
configDir <- FilePath -> IO FilePath
getAppUserDataDirectory FilePath
"vgrep"
    let configFiles :: [FilePath]
configFiles = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
configDir FilePath -> FilePath -> FilePath
</>)
            [ FilePath
"config.yaml"
            , FilePath
"config.yml"
            , FilePath
"config.json"
            , FilePath
"config" ]
    [FilePath] -> IO (Maybe FilePath)
findExistingFile [FilePath]
configFiles IO (Maybe FilePath)
-> (Maybe FilePath -> IO ConfigMonoid) -> IO ConfigMonoid
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe FilePath
Nothing         -> ConfigMonoid -> IO ConfigMonoid
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigMonoid
forall a. Monoid a => a
mempty
        Just FilePath
configFile -> FilePath -> IO (Either ParseException ConfigMonoid)
forall a. FromJSON a => FilePath -> IO (Either ParseException a)
decodeFileEither FilePath
configFile IO (Either ParseException ConfigMonoid)
-> (Either ParseException ConfigMonoid -> IO ConfigMonoid)
-> IO ConfigMonoid
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right ConfigMonoid
config -> ConfigMonoid -> IO ConfigMonoid
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigMonoid
config
            Left ParseException
err     -> do
                Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                    FilePath
"Could not parse config file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
configFile FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":"
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ParseException -> FilePath
prettyPrintParseException ParseException
err
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\nFalling back to default config."
                ConfigMonoid -> IO ConfigMonoid
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigMonoid
forall a. Monoid a => a
mempty
  where
    findExistingFile :: [FilePath] -> IO (Maybe FilePath)
    findExistingFile :: [FilePath] -> IO (Maybe FilePath)
findExistingFile = \case
        [] -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
        FilePath
f : [FilePath]
fs -> do
            Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
f
            if Bool
exists then Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
f) else [FilePath] -> IO (Maybe FilePath)
findExistingFile [FilePath]
fs

    (</>) :: FilePath -> FilePath -> FilePath
    FilePath
dir </> :: FilePath -> FilePath -> FilePath
</> FilePath
file = FilePath
dir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file


instance FromJSON ConfigMonoid where
    parseJSON :: Value -> Parser ConfigMonoid
parseJSON = FilePath
-> (Object -> Parser ConfigMonoid) -> Value -> Parser ConfigMonoid
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"ConfigMonoid" ((Object -> Parser ConfigMonoid) -> Value -> Parser ConfigMonoid)
-> (Object -> Parser ConfigMonoid) -> Value -> Parser ConfigMonoid
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        ColorsMonoid
_mcolors  <- Object
o Object -> Text -> Parser (Maybe ColorsMonoid)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"colors" Parser (Maybe ColorsMonoid) -> ColorsMonoid -> Parser ColorsMonoid
forall a. Parser (Maybe a) -> a -> Parser a
.!= ColorsMonoid
forall a. Monoid a => a
mempty
        First Int
_mtabstop <- (Maybe Int -> First Int)
-> Parser (Maybe Int) -> Parser (First Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Int -> First Int
forall a. Maybe a -> First a
First (Object
o Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"tabstop")
        First FilePath
_meditor  <- (Maybe FilePath -> First FilePath)
-> Parser (Maybe FilePath) -> Parser (First FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe FilePath -> First FilePath
forall a. Maybe a -> First a
First (Object
o Object -> Text -> Parser (Maybe FilePath)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"editor")
        KeybindingsMonoid
_mkeybindings <- Object
o Object -> Text -> Parser (Maybe KeybindingsMonoid)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"keybindings" Parser (Maybe KeybindingsMonoid)
-> KeybindingsMonoid -> Parser KeybindingsMonoid
forall a. Parser (Maybe a) -> a -> Parser a
.!= KeybindingsMonoid
forall a. Monoid a => a
mempty
        ConfigMonoid -> Parser ConfigMonoid
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigMonoid :: ColorsMonoid
-> First Int -> First FilePath -> KeybindingsMonoid -> ConfigMonoid
ConfigMonoid{First Int
First FilePath
KeybindingsMonoid
ColorsMonoid
_mkeybindings :: KeybindingsMonoid
_meditor :: First FilePath
_mtabstop :: First Int
_mcolors :: ColorsMonoid
_mkeybindings :: KeybindingsMonoid
_meditor :: First FilePath
_mtabstop :: First Int
_mcolors :: ColorsMonoid
..}

instance FromJSON ColorsMonoid where
    parseJSON :: Value -> Parser ColorsMonoid
parseJSON = Options -> Value -> Parser ColorsMonoid
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

instance FromJSON Vty.Attr where
    parseJSON :: Value -> Parser Attr
parseJSON = (Attr -> Attr) -> Parser Attr -> Parser Attr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attr -> Attr
attrToVty (Parser Attr -> Parser Attr)
-> (Value -> Parser Attr) -> Value -> Parser Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Attr
forall a. FromJSON a => Value -> Parser a
parseJSON


{- |
A JSON-parsable data type for 'Vty.Attr'.

JSON example:

>>> decodeEither' "{\"fore-color\": \"black\", \"style\": \"standout\"}" :: Either ParseException Attr
Right (Attr {foreColor = Just Black, backColor = Nothing, style = Just Standout})

JSON example without quotes:
>>> decodeEither' "{fore-color: black, style: standout}" :: Either ParseException Attr
Right (Attr {foreColor = Just Black, backColor = Nothing, style = Just Standout})

YAML example:

>>> :{
>>> decodeEither'
>>>   $  "fore-color: \"blue\"\n"
>>>   <> "back-color: \"bright-blue\"\n"
>>>   <> "style: \"reverse-video\"\n"
>>>   :: Either ParseException Attr
>>> :}
Right (Attr {foreColor = Just Blue, backColor = Just BrightBlue, style = Just ReverseVideo})

YAML example without quotes:

>>> :{
>>> decodeEither'
>>>   $  "fore-color: blue\n"
>>>   <> "back-color: bright-blue\n"
>>>   <> "style: reverse-video\n"
>>>   :: Either ParseException Attr
>>> :}
Right (Attr {foreColor = Just Blue, backColor = Just BrightBlue, style = Just ReverseVideo})

An empty JSON/YAML object yields the default colors:

>>> decodeEither' "{}" :: Either ParseException Attr
Right (Attr {foreColor = Nothing, backColor = Nothing, style = Nothing})
-}
data Attr = Attr
    { Attr -> Maybe Color
foreColor :: Maybe Color
    , Attr -> Maybe Color
backColor :: Maybe Color
    , Attr -> Maybe Style
style     :: Maybe Style
    }
    deriving (Attr -> Attr -> Bool
(Attr -> Attr -> Bool) -> (Attr -> Attr -> Bool) -> Eq Attr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attr -> Attr -> Bool
$c/= :: Attr -> Attr -> Bool
== :: Attr -> Attr -> Bool
$c== :: Attr -> Attr -> Bool
Eq, Int -> Attr -> FilePath -> FilePath
[Attr] -> FilePath -> FilePath
Attr -> FilePath
(Int -> Attr -> FilePath -> FilePath)
-> (Attr -> FilePath)
-> ([Attr] -> FilePath -> FilePath)
-> Show Attr
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Attr] -> FilePath -> FilePath
$cshowList :: [Attr] -> FilePath -> FilePath
show :: Attr -> FilePath
$cshow :: Attr -> FilePath
showsPrec :: Int -> Attr -> FilePath -> FilePath
$cshowsPrec :: Int -> Attr -> FilePath -> FilePath
Show, (forall x. Attr -> Rep Attr x)
-> (forall x. Rep Attr x -> Attr) -> Generic Attr
forall x. Rep Attr x -> Attr
forall x. Attr -> Rep Attr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Attr x -> Attr
$cfrom :: forall x. Attr -> Rep Attr x
Generic)

instance FromJSON Attr where
    parseJSON :: Value -> Parser Attr
parseJSON = Options -> Value -> Parser Attr
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

attrToVty :: Attr -> Vty.Attr
attrToVty :: Attr -> Attr
attrToVty Attr{Maybe Style
Maybe Color
style :: Maybe Style
backColor :: Maybe Color
foreColor :: Maybe Color
style :: Attr -> Maybe Style
backColor :: Attr -> Maybe Color
foreColor :: Attr -> Maybe Color
..} = [Maybe (Attr -> Attr)] -> Attr
foldAttrs
    [ (Color -> Attr -> Attr) -> Maybe Color -> Maybe (Attr -> Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Attr -> Color -> Attr) -> Color -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Color -> Attr
Vty.withForeColor (Color -> Attr -> Attr)
-> (Color -> Color) -> Color -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Color
colorToVty) Maybe Color
foreColor
    , (Color -> Attr -> Attr) -> Maybe Color -> Maybe (Attr -> Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Attr -> Color -> Attr) -> Color -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Color -> Attr
Vty.withBackColor (Color -> Attr -> Attr)
-> (Color -> Color) -> Color -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Color
colorToVty) Maybe Color
backColor
    , (Style -> Attr -> Attr) -> Maybe Style -> Maybe (Attr -> Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Attr -> Style -> Attr) -> Style -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Style -> Attr
Vty.withStyle     (Style -> Attr -> Attr)
-> (Style -> Style) -> Style -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> Style
styleToVty) Maybe Style
style ]
  where
    foldAttrs :: [Maybe (Attr -> Attr)] -> Attr
foldAttrs = ((Attr -> Attr) -> Attr -> Attr) -> Attr -> [Attr -> Attr] -> Attr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Attr -> Attr) -> Attr -> Attr
forall a b. (a -> b) -> a -> b
($) Attr
Vty.defAttr ([Attr -> Attr] -> Attr)
-> ([Maybe (Attr -> Attr)] -> [Attr -> Attr])
-> [Maybe (Attr -> Attr)]
-> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Attr -> Attr)] -> [Attr -> Attr]
forall a. [Maybe a] -> [a]
catMaybes


{- |
A JSON-parsable data type for 'Vty.Color'.

>>> decodeEither' "[\"black\",\"red\",\"bright-black\"]" :: Either ParseException [Color]
Right [Black,Red,BrightBlack]

Also works without quotes:

>>> decodeEither' "[black,red,bright-black]" :: Either ParseException [Color]
Right [Black,Red,BrightBlack]

Fails with error message if the 'Color' cannot be parsed:

>>> isLeft (decodeEither' "foo" :: Either ParseException Color)
True
-}
data Color
    = Black
    | Red
    | Green
    | Yellow
    | Blue
    | Magenta
    | Cyan
    | White
    | BrightBlack
    | BrightRed
    | BrightGreen
    | BrightYellow
    | BrightBlue
    | BrightMagenta
    | BrightCyan
    | BrightWhite
    deriving (Color -> Color -> Bool
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: Color -> Color -> Bool
Eq, Int -> Color -> FilePath -> FilePath
[Color] -> FilePath -> FilePath
Color -> FilePath
(Int -> Color -> FilePath -> FilePath)
-> (Color -> FilePath)
-> ([Color] -> FilePath -> FilePath)
-> Show Color
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Color] -> FilePath -> FilePath
$cshowList :: [Color] -> FilePath -> FilePath
show :: Color -> FilePath
$cshow :: Color -> FilePath
showsPrec :: Int -> Color -> FilePath -> FilePath
$cshowsPrec :: Int -> Color -> FilePath -> FilePath
Show, (forall x. Color -> Rep Color x)
-> (forall x. Rep Color x -> Color) -> Generic Color
forall x. Rep Color x -> Color
forall x. Color -> Rep Color x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Color x -> Color
$cfrom :: forall x. Color -> Rep Color x
Generic)

instance FromJSON Color where
    parseJSON :: Value -> Parser Color
parseJSON = Options -> Value -> Parser Color
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

colorToVty :: Color -> Vty.Color
colorToVty :: Color -> Color
colorToVty = \case
    Color
Black         -> Color
Vty.black
    Color
Red           -> Color
Vty.red
    Color
Green         -> Color
Vty.green
    Color
Yellow        -> Color
Vty.yellow
    Color
Blue          -> Color
Vty.blue
    Color
Magenta       -> Color
Vty.magenta
    Color
Cyan          -> Color
Vty.cyan
    Color
White         -> Color
Vty.white
    Color
BrightBlack   -> Color
Vty.brightBlack
    Color
BrightRed     -> Color
Vty.brightRed
    Color
BrightGreen   -> Color
Vty.brightGreen
    Color
BrightYellow  -> Color
Vty.brightYellow
    Color
BrightBlue    -> Color
Vty.brightBlue
    Color
BrightMagenta -> Color
Vty.brightMagenta
    Color
BrightCyan    -> Color
Vty.brightCyan
    Color
BrightWhite   -> Color
Vty.brightWhite


{- |
A JSON-parsable data type for 'Vty.Style'.

>>> decodeEither' "[\"standout\", \"underline\", \"bold\"]" :: Either ParseException [Style]
Right [Standout,Underline,Bold]

Also works without quotes:

>>> decodeEither' "[standout, underline, bold]" :: Either ParseException [Style]
Right [Standout,Underline,Bold]

Fails with error message if the 'Style' cannot be parsed:

>>> isLeft (decodeEither' "foo" :: Either ParseException Color)
True
-}
data Style
    = Standout
    | Underline
    | ReverseVideo
    | Blink
    | Dim
    | Bold
    deriving (Style -> Style -> Bool
(Style -> Style -> Bool) -> (Style -> Style -> Bool) -> Eq Style
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c== :: Style -> Style -> Bool
Eq, Int -> Style -> FilePath -> FilePath
[Style] -> FilePath -> FilePath
Style -> FilePath
(Int -> Style -> FilePath -> FilePath)
-> (Style -> FilePath)
-> ([Style] -> FilePath -> FilePath)
-> Show Style
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Style] -> FilePath -> FilePath
$cshowList :: [Style] -> FilePath -> FilePath
show :: Style -> FilePath
$cshow :: Style -> FilePath
showsPrec :: Int -> Style -> FilePath -> FilePath
$cshowsPrec :: Int -> Style -> FilePath -> FilePath
Show, (forall x. Style -> Rep Style x)
-> (forall x. Rep Style x -> Style) -> Generic Style
forall x. Rep Style x -> Style
forall x. Style -> Rep Style x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Style x -> Style
$cfrom :: forall x. Style -> Rep Style x
Generic)

instance FromJSON Style where
    parseJSON :: Value -> Parser Style
parseJSON = Options -> Value -> Parser Style
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

styleToVty :: Style -> Vty.Style
styleToVty :: Style -> Style
styleToVty = \case
    Style
Standout     -> Style
Vty.standout
    Style
Underline    -> Style
Vty.underline
    Style
ReverseVideo -> Style
Vty.reverseVideo
    Style
Blink        -> Style
Vty.blink
    Style
Dim          -> Style
Vty.dim
    Style
Bold         -> Style
Vty.bold


instance FromJSON KeybindingsMonoid where
    parseJSON :: Value -> Parser KeybindingsMonoid
parseJSON = Options -> Value -> Parser KeybindingsMonoid
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

instance FromJSON Command where
    parseJSON :: Value -> Parser Command
parseJSON = Options -> Value -> Parser Command
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

instance FromJSON KeybindingMap where
    parseJSON :: Value -> Parser KeybindingMap
parseJSON = (Map Chord Command -> KeybindingMap)
-> Parser (Map Chord Command) -> Parser KeybindingMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Chord Command -> KeybindingMap
KeybindingMap (Parser (Map Chord Command) -> Parser KeybindingMap)
-> (Map FilePath Command -> Parser (Map Chord Command))
-> Map FilePath Command
-> Parser KeybindingMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Parser Chord)
-> Map FilePath Command -> Parser (Map Chord Command)
forall (m :: * -> *) k' k v.
(Monad m, Ord k') =>
(k -> m k') -> Map k v -> m (Map k' v)
mapMKeys FilePath -> Parser Chord
parseChord (Map FilePath Command -> Parser KeybindingMap)
-> (Value -> Parser (Map FilePath Command))
-> Value
-> Parser KeybindingMap
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> Parser (Map FilePath Command)
forall a. FromJSON a => Value -> Parser a
parseJSON

mapMKeys :: (Monad m, Ord k') => (k -> m k') -> Map k v -> m (Map k' v)
mapMKeys :: (k -> m k') -> Map k v -> m (Map k' v)
mapMKeys k -> m k'
f = ([(k', v)] -> Map k' v) -> m [(k', v)] -> m (Map k' v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(k', v)] -> Map k' v
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (m [(k', v)] -> m (Map k' v))
-> (Map k v -> m [(k', v)]) -> Map k v -> m (Map k' v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> v -> m [(k', v)] -> m [(k', v)])
-> m [(k', v)] -> Map k v -> m [(k', v)]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey k -> v -> m [(k', v)] -> m [(k', v)]
forall b. k -> b -> m [(k', b)] -> m [(k', b)]
go ([(k', v)] -> m [(k', v)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
  where
    go :: k -> b -> m [(k', b)] -> m [(k', b)]
go k
k b
x m [(k', b)]
mxs = do
        k'
k' <- k -> m k'
f k
k
        [(k', b)]
xs <- m [(k', b)]
mxs
        [(k', b)] -> m [(k', b)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((k'
k', b
x) (k', b) -> [(k', b)] -> [(k', b)]
forall a. a -> [a] -> [a]
: [(k', b)]
xs)

parseChord :: String -> Parser Key.Chord
parseChord :: FilePath -> Parser Chord
parseChord = \case
    Char
'C' : Char
'-' : FilePath
t -> (Chord -> Chord) -> Parser Chord -> Parser Chord
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Chord -> Mod -> Chord
`Key.withModifier` Mod
Key.Ctrl)  (FilePath -> Parser Chord
parseChord FilePath
t)
    Char
'S' : Char
'-' : FilePath
t -> (Chord -> Chord) -> Parser Chord -> Parser Chord
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Chord -> Mod -> Chord
`Key.withModifier` Mod
Key.Shift) (FilePath -> Parser Chord
parseChord FilePath
t)
    Char
'M' : Char
'-' : FilePath
t -> (Chord -> Chord) -> Parser Chord -> Parser Chord
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Chord -> Mod -> Chord
`Key.withModifier` Mod
Key.Meta)  (FilePath -> Parser Chord
parseChord FilePath
t)
    [Char
c]           -> Chord -> Parser Chord
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key -> Chord
Key.key (Char -> Key
Key.Char Char
c))
    FilePath
"PgUp"        -> Chord -> Parser Chord
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key -> Chord
Key.key Key
Key.PageUp)
    FilePath
"PgDown"      -> Chord -> Parser Chord
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key -> Chord
Key.key Key
Key.PageDown)
    FilePath
"PgDn"        -> Chord -> Parser Chord
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key -> Chord
Key.key Key
Key.PageDown)
    FilePath
s | Just Key
k <- FilePath -> Maybe Key
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
s
                  -> Chord -> Parser Chord
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key -> Chord
Key.key Key
k)
      | Bool
otherwise -> FilePath -> Parser Chord
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath
"Unknown key '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
s FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"'")

jsonOptions :: Options
jsonOptions :: Options
jsonOptions = Options
defaultOptions
    { constructorTagModifier :: FilePath -> FilePath
constructorTagModifier = Char -> FilePath -> FilePath
camelTo Char
'-'
    , fieldLabelModifier :: FilePath -> FilePath
fieldLabelModifier     = Char -> FilePath -> FilePath
camelTo Char
'-' (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
stripPrefix }
  where
    stripPrefix :: FilePath -> FilePath
stripPrefix = \case
        Char
'_' : Char
'm' : FilePath
name -> FilePath
name
        Char
'_' : FilePath
name       -> FilePath
name
        FilePath
name             -> FilePath
name