{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Vgrep.Environment.Config where

import Control.Lens.Compat
import Control.Monad.IO.Class
import Data.Maybe
import Data.Monoid
import Graphics.Vty.Attributes
    ( Attr
    , blue
    , bold
    , defAttr
    , green
    , standout
    , withBackColor
    , withForeColor
    , withStyle
    )

import           Vgrep.Command
import           Vgrep.Environment.Config.Monoid
import           Vgrep.Environment.Config.Sources
import qualified Vgrep.Key                        as Key
import           Vgrep.KeybindingMap              (KeybindingMap (..))
import qualified Vgrep.KeybindingMap              as KeybindingMap


--------------------------------------------------------------------------
-- * Types
--------------------------------------------------------------------------

data Config = Config
    { Config -> Colors
_colors      :: Colors
    -- ^ Color configuration

    , Config -> Int
_tabstop     :: Int
    -- ^ Tabstop width (default: 8)

    , Config -> String
_editor      :: String
    -- ^ Executable for @e@ key (default: environment variable @$EDITOR@,
    -- or @vi@ if @$EDITOR@ is not set)

    , Config -> Keybindings
_keybindings :: Keybindings

    } deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

data Colors = Colors
    { Colors -> Attr
_lineNumbers   :: Attr
    -- ^ Line numbers (default: blue)

    , Colors -> Attr
_lineNumbersHl :: Attr
    -- ^ Highlighted line numbers (default: bold blue)

    , Colors -> Attr
_normal        :: Attr
    -- ^ Normal text (default: terminal default)

    , Colors -> Attr
_normalHl      :: Attr
    -- ^ Highlighted text (default: bold)

    , Colors -> Attr
_fileHeaders   :: Attr
    -- ^ File names in results view (default: terminal default color on
    -- green background)

    , Colors -> Attr
_selected      :: Attr
    -- ^ Selected entry (default: terminal default, inverted)

    } deriving (Colors -> Colors -> Bool
(Colors -> Colors -> Bool)
-> (Colors -> Colors -> Bool) -> Eq Colors
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Colors -> Colors -> Bool
$c/= :: Colors -> Colors -> Bool
== :: Colors -> Colors -> Bool
$c== :: Colors -> Colors -> Bool
Eq, Int -> Colors -> ShowS
[Colors] -> ShowS
Colors -> String
(Int -> Colors -> ShowS)
-> (Colors -> String) -> ([Colors] -> ShowS) -> Show Colors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Colors] -> ShowS
$cshowList :: [Colors] -> ShowS
show :: Colors -> String
$cshow :: Colors -> String
showsPrec :: Int -> Colors -> ShowS
$cshowsPrec :: Int -> Colors -> ShowS
Show)

data Keybindings = Keybindings
    { Keybindings -> KeybindingMap
_resultsKeybindings :: KeybindingMap
    -- ^ Keybindings in effect when results list is focused.

    , Keybindings -> KeybindingMap
_pagerKeybindings   :: KeybindingMap
    -- ^ Keybindings in effect when pager is focused.

    , Keybindings -> KeybindingMap
_globalKeybindings  :: KeybindingMap
    -- ^ Global keybindings are in effect both for pager and results list, but
    -- can be overridden by either one.

    } deriving (Keybindings -> Keybindings -> Bool
(Keybindings -> Keybindings -> Bool)
-> (Keybindings -> Keybindings -> Bool) -> Eq Keybindings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Keybindings -> Keybindings -> Bool
$c/= :: Keybindings -> Keybindings -> Bool
== :: Keybindings -> Keybindings -> Bool
$c== :: Keybindings -> Keybindings -> Bool
Eq, Int -> Keybindings -> ShowS
[Keybindings] -> ShowS
Keybindings -> String
(Int -> Keybindings -> ShowS)
-> (Keybindings -> String)
-> ([Keybindings] -> ShowS)
-> Show Keybindings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Keybindings] -> ShowS
$cshowList :: [Keybindings] -> ShowS
show :: Keybindings -> String
$cshow :: Keybindings -> String
showsPrec :: Int -> Keybindings -> ShowS
$cshowsPrec :: Int -> Keybindings -> ShowS
Show)


--------------------------------------------------------------------------
-- * Auto-generated Lenses
--------------------------------------------------------------------------

makeLenses ''Config
makeLenses ''Colors
makeLenses ''Keybindings


--------------------------------------------------------------------------
-- * Read Config from Monoid
--------------------------------------------------------------------------

-- | Convert a 'ConfigMonoid' to a 'Config'. Missing (@'mempty'@) values in the
-- 'ConfigMonoid' are supplied from the 'defaultConfig'.
fromConfigMonoid :: ConfigMonoid -> Config
fromConfigMonoid :: ConfigMonoid -> Config
fromConfigMonoid ConfigMonoid{First Int
First String
KeybindingsMonoid
ColorsMonoid
_mkeybindings :: ConfigMonoid -> KeybindingsMonoid
_meditor :: ConfigMonoid -> First String
_mtabstop :: ConfigMonoid -> First Int
_mcolors :: ConfigMonoid -> ColorsMonoid
_mkeybindings :: KeybindingsMonoid
_meditor :: First String
_mtabstop :: First Int
_mcolors :: ColorsMonoid
..} = Config :: Colors -> Int -> String -> Keybindings -> Config
Config
    { _colors :: Colors
_colors  = ColorsMonoid -> Colors
fromColorsMonoid ColorsMonoid
_mcolors
    , _tabstop :: Int
_tabstop = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst (Config -> Int
_tabstop Config
defaultConfig) First Int
_mtabstop
    , _editor :: String
_editor  = String -> First String -> String
forall a. a -> First a -> a
fromFirst (Config -> String
_editor  Config
defaultConfig) First String
_meditor
    , _keybindings :: Keybindings
_keybindings = KeybindingsMonoid -> Keybindings
fromKeybindingsMonoid KeybindingsMonoid
_mkeybindings }

-- | Convert a 'ColorsMonoid' to a 'Colors' config.
fromColorsMonoid :: ColorsMonoid -> Colors
fromColorsMonoid :: ColorsMonoid -> Colors
fromColorsMonoid ColorsMonoid{First Attr
_mselected :: ColorsMonoid -> First Attr
_mfileHeaders :: ColorsMonoid -> First Attr
_mnormalHl :: ColorsMonoid -> First Attr
_mnormal :: ColorsMonoid -> First Attr
_mlineNumbersHl :: ColorsMonoid -> First Attr
_mlineNumbers :: ColorsMonoid -> First Attr
_mselected :: First Attr
_mfileHeaders :: First Attr
_mnormalHl :: First Attr
_mnormal :: First Attr
_mlineNumbersHl :: First Attr
_mlineNumbers :: First Attr
..} = Colors :: Attr -> Attr -> Attr -> Attr -> Attr -> Attr -> Colors
Colors
    { _lineNumbers :: Attr
_lineNumbers   = Attr -> First Attr -> Attr
forall a. a -> First a -> a
fromFirst (Colors -> Attr
_lineNumbers   Colors
defaultColors) First Attr
_mlineNumbers
    , _lineNumbersHl :: Attr
_lineNumbersHl = Attr -> First Attr -> Attr
forall a. a -> First a -> a
fromFirst (Colors -> Attr
_lineNumbersHl Colors
defaultColors) First Attr
_mlineNumbersHl
    , _normal :: Attr
_normal        = Attr -> First Attr -> Attr
forall a. a -> First a -> a
fromFirst (Colors -> Attr
_normal        Colors
defaultColors) First Attr
_mnormal
    , _normalHl :: Attr
_normalHl      = Attr -> First Attr -> Attr
forall a. a -> First a -> a
fromFirst (Colors -> Attr
_normalHl      Colors
defaultColors) First Attr
_mnormalHl
    , _fileHeaders :: Attr
_fileHeaders   = Attr -> First Attr -> Attr
forall a. a -> First a -> a
fromFirst (Colors -> Attr
_fileHeaders   Colors
defaultColors) First Attr
_mfileHeaders
    , _selected :: Attr
_selected      = Attr -> First Attr -> Attr
forall a. a -> First a -> a
fromFirst (Colors -> Attr
_selected      Colors
defaultColors) First Attr
_mselected }

fromFirst :: a -> First a -> a
fromFirst :: a -> First a -> a
fromFirst a
a = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
a (Maybe a -> a) -> (First a -> Maybe a) -> First a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First a -> Maybe a
forall a. First a -> Maybe a
getFirst

fromKeybindingsMonoid :: KeybindingsMonoid -> Keybindings
fromKeybindingsMonoid :: KeybindingsMonoid -> Keybindings
fromKeybindingsMonoid KeybindingsMonoid{Maybe KeybindingMap
_mglobalKeybindings :: KeybindingsMonoid -> Maybe KeybindingMap
_mpagerKeybindings :: KeybindingsMonoid -> Maybe KeybindingMap
_mresultsKeybindings :: KeybindingsMonoid -> Maybe KeybindingMap
_mglobalKeybindings :: Maybe KeybindingMap
_mpagerKeybindings :: Maybe KeybindingMap
_mresultsKeybindings :: Maybe KeybindingMap
..} = Keybindings :: KeybindingMap -> KeybindingMap -> KeybindingMap -> Keybindings
Keybindings
    { _resultsKeybindings :: KeybindingMap
_resultsKeybindings = KeybindingMap -> Maybe KeybindingMap -> KeybindingMap
forall a. a -> Maybe a -> a
fromMaybe KeybindingMap
forall a. Monoid a => a
mempty Maybe KeybindingMap
_mresultsKeybindings KeybindingMap -> KeybindingMap -> KeybindingMap
forall a. Semigroup a => a -> a -> a
<> Keybindings -> KeybindingMap
_resultsKeybindings Keybindings
defaultKeybindings
    , _pagerKeybindings :: KeybindingMap
_pagerKeybindings   = KeybindingMap -> Maybe KeybindingMap -> KeybindingMap
forall a. a -> Maybe a -> a
fromMaybe KeybindingMap
forall a. Monoid a => a
mempty Maybe KeybindingMap
_mpagerKeybindings   KeybindingMap -> KeybindingMap -> KeybindingMap
forall a. Semigroup a => a -> a -> a
<> Keybindings -> KeybindingMap
_pagerKeybindings   Keybindings
defaultKeybindings
    , _globalKeybindings :: KeybindingMap
_globalKeybindings  = KeybindingMap -> Maybe KeybindingMap -> KeybindingMap
forall a. a -> Maybe a -> a
fromMaybe KeybindingMap
forall a. Monoid a => a
mempty Maybe KeybindingMap
_mglobalKeybindings  KeybindingMap -> KeybindingMap -> KeybindingMap
forall a. Semigroup a => a -> a -> a
<> Keybindings -> KeybindingMap
_globalKeybindings  Keybindings
defaultKeybindings }


--------------------------------------------------------------------------
-- * Default Config
--------------------------------------------------------------------------

defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config :: Colors -> Int -> String -> Keybindings -> Config
Config
    { _colors :: Colors
_colors = Colors
defaultColors
    , _tabstop :: Int
_tabstop = Int
8
    , _editor :: String
_editor = String
"vi"
    , _keybindings :: Keybindings
_keybindings = Keybindings
defaultKeybindings }

defaultColors :: Colors
defaultColors :: Colors
defaultColors = Colors :: Attr -> Attr -> Attr -> Attr -> Attr -> Attr -> Colors
Colors
    { _lineNumbers :: Attr
_lineNumbers   = Attr
defAttr Attr -> Color -> Attr
`withForeColor` Color
blue
    , _lineNumbersHl :: Attr
_lineNumbersHl = Attr
defAttr Attr -> Color -> Attr
`withForeColor` Color
blue
                               Attr -> Style -> Attr
`withStyle` Style
bold
    , _normal :: Attr
_normal        = Attr
defAttr
    , _normalHl :: Attr
_normalHl      = Attr
defAttr Attr -> Style -> Attr
`withStyle` Style
bold
    , _fileHeaders :: Attr
_fileHeaders   = Attr
defAttr Attr -> Color -> Attr
`withBackColor` Color
green
    , _selected :: Attr
_selected      = Attr
defAttr Attr -> Style -> Attr
`withStyle` Style
standout }

defaultKeybindings :: Keybindings
defaultKeybindings :: Keybindings
defaultKeybindings = Keybindings :: KeybindingMap -> KeybindingMap -> KeybindingMap -> Keybindings
Keybindings
    { _resultsKeybindings :: KeybindingMap
_resultsKeybindings = [(Chord, Command)] -> KeybindingMap
KeybindingMap.fromList
        [ (Key -> Chord
Key.key Key
Key.Up,          Command
ResultsUp)
        , (Key -> Chord
Key.key Key
Key.Down,        Command
ResultsDown)
        , (Key -> Chord
Key.key Key
Key.PageUp,      Command
ResultsPageUp)
        , (Key -> Chord
Key.key Key
Key.PageDown,    Command
ResultsPageDown)
        , (Key -> Chord
Key.key Key
Key.Enter,       Command
PagerGotoResult)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'k'),  Command
ResultsUp)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'j'),  Command
ResultsDown)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'b') Chord -> Mod -> Chord
`Key.withModifier` Mod
Key.Ctrl, Command
ResultsPageUp)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'f') Chord -> Mod -> Chord
`Key.withModifier` Mod
Key.Ctrl, Command
ResultsPageDown)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'f'),  Command
DisplayResultsOnly)
        , (Key -> Chord
Key.key Key
Key.Tab,         Command
SplitFocusPager) ]
    , _pagerKeybindings :: KeybindingMap
_pagerKeybindings = [(Chord, Command)] -> KeybindingMap
KeybindingMap.fromList
        [ (Key -> Chord
Key.key Key
Key.Up,          Command
PagerUp)
        , (Key -> Chord
Key.key Key
Key.Down,        Command
PagerDown)
        , (Key -> Chord
Key.key Key
Key.PageUp,      Command
PagerPageUp)
        , (Key -> Chord
Key.key Key
Key.PageDown,    Command
PagerPageDown)
        , (Key -> Chord
Key.key Key
Key.Left,        Command
PagerScrollLeft)
        , (Key -> Chord
Key.key Key
Key.Right,       Command
PagerScrollRight)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'k'),  Command
PagerUp)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'j'),  Command
PagerDown)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'h'),  Command
PagerScrollLeft)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'l'),  Command
PagerScrollRight)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'u') Chord -> Mod -> Chord
`Key.withModifier` Mod
Key.Ctrl, Command
PagerHalfPageUp)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'd') Chord -> Mod -> Chord
`Key.withModifier` Mod
Key.Ctrl, Command
PagerHalfPageDown)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'b') Chord -> Mod -> Chord
`Key.withModifier` Mod
Key.Ctrl, Command
PagerPageUp)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'f') Chord -> Mod -> Chord
`Key.withModifier` Mod
Key.Ctrl, Command
PagerPageDown)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'f'),  Command
DisplayPagerOnly)
        , (Key -> Chord
Key.key Key
Key.Tab,         Command
SplitFocusResults)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'q'),  Command
DisplayResultsOnly) ]
    , _globalKeybindings :: KeybindingMap
_globalKeybindings = [(Chord, Command)] -> KeybindingMap
KeybindingMap.fromList
        [ (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'e'),  Command
OpenFileInEditor)
        , (Key -> Chord
Key.key (Char -> Key
Key.Char Char
'q'),  Command
Exit) ]
    }


--------------------------------------------------------------------------
-- * Config Loader
--------------------------------------------------------------------------

-- | Gathers 'ConfigMonoid's from various sources and builds a 'Config'
-- based on the 'defaultConfig':
--
-- * Config from environment variables
-- * The configuration specified in the config file
-- * External config, e.g. from command line
--
-- where the latter ones override the earlier ones.
loadConfig
    :: MonadIO io
    => ConfigMonoid -- ^ External config from command line
    -> io Config
loadConfig :: ConfigMonoid -> io Config
loadConfig ConfigMonoid
configFromArgs = do
    [ConfigMonoid]
configs <- [io ConfigMonoid] -> io [ConfigMonoid]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ ConfigMonoid -> io ConfigMonoid
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigMonoid
configFromArgs
        , io ConfigMonoid
forall (io :: * -> *). MonadIO io => io ConfigMonoid
configFromFile
        , io ConfigMonoid
forall (io :: * -> *). MonadIO io => io ConfigMonoid
editorConfigFromEnv ]
    Config -> io Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfigMonoid -> Config
fromConfigMonoid ([ConfigMonoid] -> ConfigMonoid
forall a. Monoid a => [a] -> a
mconcat [ConfigMonoid]
configs))