{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE ApplicativeDo     #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE LambdaCase        #-}

{-|
Module      : Client.Configuration
Description : Client configuration format and operations
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module defines the top-level configuration information for the client.
-}

module Client.Configuration
  (
  -- * Configuration type
    Configuration(..)
  , ConfigurationFailure(..)
  , LayoutMode(..)
  , EditMode(..)
  , PaddingMode(..)
  , ExtensionConfiguration(..)

  -- * Lenses
  , configDefaults
  , configServers
  , configPalette
  , configWindowNames
  , configNickPadding
  , configMacros
  , configExtensions
  , configExtraHighlights
  , configNeverHighlights
  , configUrlOpener
  , configIgnores
  , configActivityBar
  , configBellOnMention
  , configHideMeta
  , configKeyMap
  , configLayout
  , configShowPing
  , configJumpModifier
  , configDigraphs
  , configNotifications

  , configNetworkPalette
  , extensionPath
  , extensionRtldFlags
  , extensionArgs

  -- * Loading configuration
  , loadConfiguration

  -- * Resolving paths
  , getConfigPath

  -- * Specification
  , configurationSpec

  -- * FilePath resolution
  , FilePathContext
  , newFilePathContext
  , resolveFilePath

  -- * Url opener configuration
  , UrlOpener(..)
  , UrlArgument(..)
  ) where

import Client.Commands.Interpolation (Macro)
import Client.Commands.Recognizer (Recognizer)
import Client.Configuration.Colors (attrSpec)
import Client.Configuration.Macros (macroMapSpec)
import Client.Configuration.Notifications (NotifyWith, notifySpec, notifyWithDefault)
import Client.Configuration.ServerSettings
import Client.EventLoop.Actions
import Client.Image.Palette
import Config
import Config.Macro
import Config.Schema
import Control.Exception
import Control.Lens hiding (List)
import Data.Foldable (foldl', toList)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map  (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid (Endo(..))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Vector qualified as Vector
import Digraphs (Digraph(..))
import Graphics.Vty.Input.Events (Modifier(..), Key(..))
import Irc.Identifier (Identifier, mkId)
import System.Directory ( getHomeDirectory, getXdgDirectory, XdgDirectory(XdgConfig))
import System.FilePath ((</>), isAbsolute, joinPath, splitDirectories, takeDirectory)
import System.IO.Error (ioeGetFileName, isDoesNotExistError)
import System.Posix.DynamicLinker (RTLDFlags(..))

-- | Top-level client configuration information. When connecting to a
-- server configuration from '_configServers' is used where possible,
-- otherwise '_configDefaults' is used.
data Configuration = Configuration
  { Configuration -> ServerSettings
_configDefaults        :: ServerSettings -- ^ Default connection settings
  , Configuration -> HashMap Text ServerSettings
_configServers         :: (HashMap Text ServerSettings) -- ^ Host-specific settings
  , Configuration -> Palette
_configPalette         :: Palette -- ^ User-customized color palette
  , Configuration -> Text
_configWindowNames     :: Text -- ^ Names of windows, used when alt-jumping)
  , Configuration -> [Identifier]
_configExtraHighlights :: [Identifier] -- ^ Extra highlight nicks/terms
  , Configuration -> [Identifier]
_configNeverHighlights :: [Identifier] -- ^ Never highlight nicks/terms
  , Configuration -> PaddingMode
_configNickPadding     :: PaddingMode -- ^ Padding of nicks in messages
  , Configuration -> Recognizer Macro
_configMacros          :: Recognizer Macro -- ^ command macros
  , Configuration -> [ExtensionConfiguration]
_configExtensions      :: [ExtensionConfiguration] -- ^ extensions to load
  , Configuration -> Maybe UrlOpener
_configUrlOpener       :: Maybe UrlOpener -- ^ paths to url opening executable
  , Configuration -> [Text]
_configIgnores         :: [Text] -- ^ initial ignore mask list
  , Configuration -> Bool
_configActivityBar     :: Bool -- ^ initially visibility of the activity bar
  , Configuration -> Bool
_configBellOnMention   :: Bool -- ^ notify terminal on mention
  , Configuration -> Bool
_configHideMeta        :: Bool -- ^ default setting for hidemeta on new windows
  , Configuration -> KeyMap
_configKeyMap          :: KeyMap -- ^ keyboard bindings
  , Configuration -> LayoutMode
_configLayout          :: LayoutMode -- ^ Default layout on startup
  , Configuration -> Bool
_configShowPing        :: Bool -- ^ visibility of ping time
  , Configuration -> [Modifier]
_configJumpModifier    :: [Modifier] -- ^ Modifier used for jumping windows
  , Configuration -> Map Digraph Text
_configDigraphs        :: Map Digraph Text -- ^ Extra digraphs
  , Configuration -> NotifyWith
_configNotifications   :: NotifyWith
  }
  deriving Int -> Configuration -> ShowS
[Configuration] -> ShowS
Configuration -> FilePath
(Int -> Configuration -> ShowS)
-> (Configuration -> FilePath)
-> ([Configuration] -> ShowS)
-> Show Configuration
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Configuration -> ShowS
showsPrec :: Int -> Configuration -> ShowS
$cshow :: Configuration -> FilePath
show :: Configuration -> FilePath
$cshowList :: [Configuration] -> ShowS
showList :: [Configuration] -> ShowS
Show

data UrlOpener = UrlOpener FilePath [UrlArgument]
  deriving Int -> UrlOpener -> ShowS
[UrlOpener] -> ShowS
UrlOpener -> FilePath
(Int -> UrlOpener -> ShowS)
-> (UrlOpener -> FilePath)
-> ([UrlOpener] -> ShowS)
-> Show UrlOpener
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UrlOpener -> ShowS
showsPrec :: Int -> UrlOpener -> ShowS
$cshow :: UrlOpener -> FilePath
show :: UrlOpener -> FilePath
$cshowList :: [UrlOpener] -> ShowS
showList :: [UrlOpener] -> ShowS
Show

data UrlArgument = UrlArgLiteral String | UrlArgUrl
  deriving Int -> UrlArgument -> ShowS
[UrlArgument] -> ShowS
UrlArgument -> FilePath
(Int -> UrlArgument -> ShowS)
-> (UrlArgument -> FilePath)
-> ([UrlArgument] -> ShowS)
-> Show UrlArgument
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UrlArgument -> ShowS
showsPrec :: Int -> UrlArgument -> ShowS
$cshow :: UrlArgument -> FilePath
show :: UrlArgument -> FilePath
$cshowList :: [UrlArgument] -> ShowS
showList :: [UrlArgument] -> ShowS
Show

-- | Setting for how to pad the message prefix.
data PaddingMode
  = LeftPadding  !Int -- ^ Whitespace add to the left side of chat prefix
  | RightPadding !Int -- ^ Whitespace add to the right side of chat prefix
  | NoPadding         -- ^ No whitespace added
  deriving (Int -> PaddingMode -> ShowS
[PaddingMode] -> ShowS
PaddingMode -> FilePath
(Int -> PaddingMode -> ShowS)
-> (PaddingMode -> FilePath)
-> ([PaddingMode] -> ShowS)
-> Show PaddingMode
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PaddingMode -> ShowS
showsPrec :: Int -> PaddingMode -> ShowS
$cshow :: PaddingMode -> FilePath
show :: PaddingMode -> FilePath
$cshowList :: [PaddingMode] -> ShowS
showList :: [PaddingMode] -> ShowS
Show)

data LayoutMode
  -- | Vertically stack all windows in a single column
  = OneColumn
  -- | Vertically stack extra windows in a second column
  | TwoColumn
  deriving Int -> LayoutMode -> ShowS
[LayoutMode] -> ShowS
LayoutMode -> FilePath
(Int -> LayoutMode -> ShowS)
-> (LayoutMode -> FilePath)
-> ([LayoutMode] -> ShowS)
-> Show LayoutMode
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LayoutMode -> ShowS
showsPrec :: Int -> LayoutMode -> ShowS
$cshow :: LayoutMode -> FilePath
show :: LayoutMode -> FilePath
$cshowList :: [LayoutMode] -> ShowS
showList :: [LayoutMode] -> ShowS
Show

data EditMode
  = SingleLineEditor
  | MultiLineEditor
  deriving Int -> EditMode -> ShowS
[EditMode] -> ShowS
EditMode -> FilePath
(Int -> EditMode -> ShowS)
-> (EditMode -> FilePath) -> ([EditMode] -> ShowS) -> Show EditMode
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EditMode -> ShowS
showsPrec :: Int -> EditMode -> ShowS
$cshow :: EditMode -> FilePath
show :: EditMode -> FilePath
$cshowList :: [EditMode] -> ShowS
showList :: [EditMode] -> ShowS
Show

-- | Failure cases when loading a configuration file.
data ConfigurationFailure

  -- | Error message from reading configuration file
  = ConfigurationReadFailed String

  -- | Error message from parser or lexer
  | ConfigurationParseFailed FilePath String

  -- | Error message from loading parsed configuration
  | ConfigurationMalformed FilePath String
  deriving Int -> ConfigurationFailure -> ShowS
[ConfigurationFailure] -> ShowS
ConfigurationFailure -> FilePath
(Int -> ConfigurationFailure -> ShowS)
-> (ConfigurationFailure -> FilePath)
-> ([ConfigurationFailure] -> ShowS)
-> Show ConfigurationFailure
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigurationFailure -> ShowS
showsPrec :: Int -> ConfigurationFailure -> ShowS
$cshow :: ConfigurationFailure -> FilePath
show :: ConfigurationFailure -> FilePath
$cshowList :: [ConfigurationFailure] -> ShowS
showList :: [ConfigurationFailure] -> ShowS
Show

-- | default instance
instance Exception ConfigurationFailure

-- | Configuration information for run-time loaded dynamic
-- library extensions.
data ExtensionConfiguration = ExtensionConfiguration
  { ExtensionConfiguration -> FilePath
_extensionPath      :: FilePath -- ^ path to shared object
  , ExtensionConfiguration -> [RTLDFlags]
_extensionRtldFlags :: [RTLDFlags] -- ^ dynamic linker flags
  , ExtensionConfiguration -> [Text]
_extensionArgs      :: [Text] -- ^ arguments to the extension on startup
  }
  deriving Int -> ExtensionConfiguration -> ShowS
[ExtensionConfiguration] -> ShowS
ExtensionConfiguration -> FilePath
(Int -> ExtensionConfiguration -> ShowS)
-> (ExtensionConfiguration -> FilePath)
-> ([ExtensionConfiguration] -> ShowS)
-> Show ExtensionConfiguration
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExtensionConfiguration -> ShowS
showsPrec :: Int -> ExtensionConfiguration -> ShowS
$cshow :: ExtensionConfiguration -> FilePath
show :: ExtensionConfiguration -> FilePath
$cshowList :: [ExtensionConfiguration] -> ShowS
showList :: [ExtensionConfiguration] -> ShowS
Show

makeLenses ''Configuration
makeLenses ''ExtensionConfiguration

-- | The default client behavior for naming windows is to use the first two
-- rows of a QWERTY keyboard followed by the first two rows combined with
-- SHIFT.
defaultWindowNames :: Text
defaultWindowNames :: Text
defaultWindowNames = Text
"1234567890qwertyuiop!@#$%^&*()QWERTYUIOP"

-- | Uses 'getXdgDirectory' 'XdgConfig' to find @~/.config/glirc/config@
getConfigPath :: IO FilePath
getConfigPath :: IO FilePath
getConfigPath =
  do FilePath
dir <- XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgConfig FilePath
"glirc"
     return (FilePath
dir FilePath -> ShowS
</> FilePath
"config")

-- | Load the configuration file defaulting to @~/.glirc/config@.
--
-- Given configuration path is optional and actual path used will
-- be returns on success
loadConfiguration ::
  Maybe FilePath {- ^ path to configuration file -} ->
  IO (Either ConfigurationFailure (FilePath, Configuration))
loadConfiguration :: Maybe FilePath
-> IO (Either ConfigurationFailure (FilePath, Configuration))
loadConfiguration Maybe FilePath
mbPath = IO (FilePath, Configuration)
-> IO (Either ConfigurationFailure (FilePath, Configuration))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (FilePath, Configuration)
 -> IO (Either ConfigurationFailure (FilePath, Configuration)))
-> IO (FilePath, Configuration)
-> IO (Either ConfigurationFailure (FilePath, Configuration))
forall a b. (a -> b) -> a -> b
$
  do FilePath
path <- case Maybe FilePath
mbPath of
               Maybe FilePath
Nothing -> IO FilePath
getConfigPath
               Just FilePath
p  -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
p

     FilePathContext
ctx <- FilePath -> IO FilePathContext
newFilePathContext FilePath
path

     let toPath :: Text -> p -> f FilePath
toPath Text
txt p
_ = FilePath -> f FilePath
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePathContext -> ShowS
resolveFilePath FilePathContext
ctx (Text -> FilePath
Text.unpack Text
txt))
     Value FilePosition
rawcfg <- (Text -> FilePath -> IO FilePath)
-> FilePath -> IO (Value FilePosition)
loadFileWithMacros Text -> FilePath -> IO FilePath
forall {f :: * -> *} {p}. Applicative f => Text -> p -> f FilePath
toPath FilePath
path
        IO (Value FilePosition)
-> [Handler (Value FilePosition)] -> IO (Value FilePosition)
forall a. IO a -> [Handler a] -> IO a
`catches`
        [(LoadFileError -> IO (Value FilePosition))
-> Handler (Value FilePosition)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((LoadFileError -> IO (Value FilePosition))
 -> Handler (Value FilePosition))
-> (LoadFileError -> IO (Value FilePosition))
-> Handler (Value FilePosition)
forall a b. (a -> b) -> a -> b
$ \LoadFileError
e -> case LoadFileError
e of
           LoadFileParseError FilePath
fp ParseError
pe -> ConfigurationFailure -> IO (Value FilePosition)
forall e a. Exception e => e -> IO a
throwIO (FilePath -> FilePath -> ConfigurationFailure
ConfigurationParseFailed FilePath
fp (ParseError -> FilePath
forall e. Exception e => e -> FilePath
displayException ParseError
pe))
           LoadFileMacroError (UndeclaredVariable FilePosition
a Text
var) -> FilePosition -> FilePath -> IO (Value FilePosition)
forall a. FilePosition -> FilePath -> IO a
badMacro FilePosition
a (FilePath
"undeclared variable: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack Text
var)
           LoadFileMacroError (BadSplice FilePosition
a)              -> FilePosition -> FilePath -> IO (Value FilePosition)
forall a. FilePosition -> FilePath -> IO a
badMacro FilePosition
a FilePath
"bad @splice"
           LoadFileMacroError (BadLoad FilePosition
a)                -> FilePosition -> FilePath -> IO (Value FilePosition)
forall a. FilePosition -> FilePath -> IO a
badMacro FilePosition
a FilePath
"bad @load"
           LoadFileMacroError (UnknownDirective FilePosition
a Text
dir)   -> FilePosition -> FilePath -> IO (Value FilePosition)
forall a. FilePosition -> FilePath -> IO a
badMacro FilePosition
a (FilePath
"unknown directive: @" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack Text
dir)
        ,(IOError -> IO (Value FilePosition))
-> Handler (Value FilePosition)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOError -> IO (Value FilePosition))
 -> Handler (Value FilePosition))
-> (IOError -> IO (Value FilePosition))
-> Handler (Value FilePosition)
forall a b. (a -> b) -> a -> b
$ \IOError
e ->
            if IOError -> Bool
isDoesNotExistError IOError
e Bool -> Bool -> Bool
&&
               Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe FilePath
mbPath Bool -> Bool -> Bool
&&
               IOError -> Maybe FilePath
ioeGetFileName IOError
e Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
path
            then Value FilePosition -> IO (Value FilePosition)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePosition -> [Section FilePosition] -> Value FilePosition
forall a. a -> [Section a] -> Value a
Sections (FilePath -> Position -> FilePosition
FilePosition FilePath
path (Int -> Int -> Int -> Position
Position Int
0 Int
0 Int
0)) [])
            else ConfigurationFailure -> IO (Value FilePosition)
forall e a. Exception e => e -> IO a
throwIO (FilePath -> ConfigurationFailure
ConfigurationReadFailed (IOError -> FilePath
forall e. Exception e => e -> FilePath
displayException IOError
e))
        ]

     case ValueSpec (ServerSettings -> Configuration)
-> Value FilePosition
-> Either
     (ValueSpecMismatch FilePosition) (ServerSettings -> Configuration)
forall a p.
ValueSpec a -> Value p -> Either (ValueSpecMismatch p) a
loadValue ValueSpec (ServerSettings -> Configuration)
configurationSpec Value FilePosition
rawcfg of
       Left ValueSpecMismatch FilePosition
e -> ConfigurationFailure -> IO (FilePath, Configuration)
forall e a. Exception e => e -> IO a
throwIO
               (ConfigurationFailure -> IO (FilePath, Configuration))
-> ConfigurationFailure -> IO (FilePath, Configuration)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> ConfigurationFailure
ConfigurationMalformed FilePath
path
               (FilePath -> ConfigurationFailure)
-> FilePath -> ConfigurationFailure
forall a b. (a -> b) -> a -> b
$ ValueSpecMismatch FilePosition -> FilePath
forall e. Exception e => e -> FilePath
displayException ValueSpecMismatch FilePosition
e
       Right ServerSettings -> Configuration
cfg -> (FilePath, Configuration) -> IO (FilePath, Configuration)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
path, FilePathContext -> Configuration -> Configuration
resolvePaths FilePathContext
ctx (ServerSettings -> Configuration
cfg ServerSettings
defaultServerSettings))

badMacro :: FilePosition -> String -> IO a
badMacro :: forall a. FilePosition -> FilePath -> IO a
badMacro (FilePosition FilePath
path Position
posn) FilePath
msg =
  ConfigurationFailure -> IO a
forall e a. Exception e => e -> IO a
throwIO (ConfigurationFailure -> IO a) -> ConfigurationFailure -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> ConfigurationFailure
ConfigurationMalformed FilePath
path
          (FilePath -> ConfigurationFailure)
-> FilePath -> ConfigurationFailure
forall a b. (a -> b) -> a -> b
$ FilePath
"line "    FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Position -> Int
posLine   Position
posn) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
            FilePath
" column " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Position -> Int
posColumn Position
posn) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
            FilePath
": "       FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
msg

-- | Resolve all the potentially relative file paths in the configuration file
resolvePaths :: FilePathContext -> Configuration -> Configuration
resolvePaths :: FilePathContext -> Configuration -> Configuration
resolvePaths FilePathContext
ctx =
  let res :: ShowS
res = FilePathContext -> ShowS
resolveFilePath FilePathContext
ctx
      resolveServerFilePaths :: ServerSettings -> ServerSettings
resolveServerFilePaths = ASetter ServerSettings ServerSettings FilePath FilePath
-> ShowS -> ServerSettings -> ServerSettings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Maybe FilePath -> Identity (Maybe FilePath))
-> ServerSettings -> Identity ServerSettings
Lens' ServerSettings (Maybe FilePath)
ssTlsClientCert ((Maybe FilePath -> Identity (Maybe FilePath))
 -> ServerSettings -> Identity ServerSettings)
-> ((FilePath -> Identity FilePath)
    -> Maybe FilePath -> Identity (Maybe FilePath))
-> ASetter ServerSettings ServerSettings FilePath FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Identity FilePath)
-> Maybe FilePath -> Identity (Maybe FilePath)
Setter (Maybe FilePath) (Maybe FilePath) FilePath FilePath
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ShowS
res
                             (ServerSettings -> ServerSettings)
-> (ServerSettings -> ServerSettings)
-> ServerSettings
-> ServerSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter ServerSettings ServerSettings FilePath FilePath
-> ShowS -> ServerSettings -> ServerSettings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Maybe FilePath -> Identity (Maybe FilePath))
-> ServerSettings -> Identity ServerSettings
Lens' ServerSettings (Maybe FilePath)
ssTlsClientKey  ((Maybe FilePath -> Identity (Maybe FilePath))
 -> ServerSettings -> Identity ServerSettings)
-> ((FilePath -> Identity FilePath)
    -> Maybe FilePath -> Identity (Maybe FilePath))
-> ASetter ServerSettings ServerSettings FilePath FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Identity FilePath)
-> Maybe FilePath -> Identity (Maybe FilePath)
Setter (Maybe FilePath) (Maybe FilePath) FilePath FilePath
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ShowS
res
                             (ServerSettings -> ServerSettings)
-> (ServerSettings -> ServerSettings)
-> ServerSettings
-> ServerSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter ServerSettings ServerSettings FilePath FilePath
-> ShowS -> ServerSettings -> ServerSettings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Maybe FilePath -> Identity (Maybe FilePath))
-> ServerSettings -> Identity ServerSettings
Lens' ServerSettings (Maybe FilePath)
ssTlsServerCert ((Maybe FilePath -> Identity (Maybe FilePath))
 -> ServerSettings -> Identity ServerSettings)
-> ((FilePath -> Identity FilePath)
    -> Maybe FilePath -> Identity (Maybe FilePath))
-> ASetter ServerSettings ServerSettings FilePath FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Identity FilePath)
-> Maybe FilePath -> Identity (Maybe FilePath)
Setter (Maybe FilePath) (Maybe FilePath) FilePath FilePath
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ShowS
res
                             (ServerSettings -> ServerSettings)
-> (ServerSettings -> ServerSettings)
-> ServerSettings
-> ServerSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter ServerSettings ServerSettings FilePath FilePath
-> ShowS -> ServerSettings -> ServerSettings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Maybe SaslMechanism -> Identity (Maybe SaslMechanism))
-> ServerSettings -> Identity ServerSettings
Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism ((Maybe SaslMechanism -> Identity (Maybe SaslMechanism))
 -> ServerSettings -> Identity ServerSettings)
-> ((FilePath -> Identity FilePath)
    -> Maybe SaslMechanism -> Identity (Maybe SaslMechanism))
-> ASetter ServerSettings ServerSettings FilePath FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SaslMechanism -> Identity SaslMechanism)
-> Maybe SaslMechanism -> Identity (Maybe SaslMechanism)
Setter
  (Maybe SaslMechanism)
  (Maybe SaslMechanism)
  SaslMechanism
  SaslMechanism
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((SaslMechanism -> Identity SaslMechanism)
 -> Maybe SaslMechanism -> Identity (Maybe SaslMechanism))
-> ((FilePath -> Identity FilePath)
    -> SaslMechanism -> Identity SaslMechanism)
-> (FilePath -> Identity FilePath)
-> Maybe SaslMechanism
-> Identity (Maybe SaslMechanism)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Text, Text, FilePath)
 -> Identity (Maybe Text, Text, FilePath))
-> SaslMechanism -> Identity SaslMechanism
Prism' SaslMechanism (Maybe Text, Text, FilePath)
_SaslEcdsa (((Maybe Text, Text, FilePath)
  -> Identity (Maybe Text, Text, FilePath))
 -> SaslMechanism -> Identity SaslMechanism)
-> ((FilePath -> Identity FilePath)
    -> (Maybe Text, Text, FilePath)
    -> Identity (Maybe Text, Text, FilePath))
-> (FilePath -> Identity FilePath)
-> SaslMechanism
-> Identity SaslMechanism
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Identity FilePath)
-> (Maybe Text, Text, FilePath)
-> Identity (Maybe Text, Text, FilePath)
forall s t a b. Field3 s t a b => Lens s t a b
Lens
  (Maybe Text, Text, FilePath)
  (Maybe Text, Text, FilePath)
  FilePath
  FilePath
_3) ShowS
res
                             (ServerSettings -> ServerSettings)
-> (ServerSettings -> ServerSettings)
-> ServerSettings
-> ServerSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter ServerSettings ServerSettings FilePath FilePath
-> ShowS -> ServerSettings -> ServerSettings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Maybe FilePath -> Identity (Maybe FilePath))
-> ServerSettings -> Identity ServerSettings
Lens' ServerSettings (Maybe FilePath)
ssLogDir        ((Maybe FilePath -> Identity (Maybe FilePath))
 -> ServerSettings -> Identity ServerSettings)
-> ((FilePath -> Identity FilePath)
    -> Maybe FilePath -> Identity (Maybe FilePath))
-> ASetter ServerSettings ServerSettings FilePath FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Identity FilePath)
-> Maybe FilePath -> Identity (Maybe FilePath)
Setter (Maybe FilePath) (Maybe FilePath) FilePath FilePath
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ShowS
res
  in ASetter Configuration Configuration FilePath FilePath
-> ShowS -> Configuration -> Configuration
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (([ExtensionConfiguration] -> Identity [ExtensionConfiguration])
-> Configuration -> Identity Configuration
Lens' Configuration [ExtensionConfiguration]
configExtensions (([ExtensionConfiguration] -> Identity [ExtensionConfiguration])
 -> Configuration -> Identity Configuration)
-> ((FilePath -> Identity FilePath)
    -> [ExtensionConfiguration] -> Identity [ExtensionConfiguration])
-> ASetter Configuration Configuration FilePath FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtensionConfiguration -> Identity ExtensionConfiguration)
-> [ExtensionConfiguration] -> Identity [ExtensionConfiguration]
Setter
  [ExtensionConfiguration]
  [ExtensionConfiguration]
  ExtensionConfiguration
  ExtensionConfiguration
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((ExtensionConfiguration -> Identity ExtensionConfiguration)
 -> [ExtensionConfiguration] -> Identity [ExtensionConfiguration])
-> ((FilePath -> Identity FilePath)
    -> ExtensionConfiguration -> Identity ExtensionConfiguration)
-> (FilePath -> Identity FilePath)
-> [ExtensionConfiguration]
-> Identity [ExtensionConfiguration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Identity FilePath)
-> ExtensionConfiguration -> Identity ExtensionConfiguration
Lens' ExtensionConfiguration FilePath
extensionPath) ShowS
res
   (Configuration -> Configuration)
-> (Configuration -> Configuration)
-> Configuration
-> Configuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Configuration Configuration ServerSettings ServerSettings
-> (ServerSettings -> ServerSettings)
-> Configuration
-> Configuration
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((HashMap Text ServerSettings
 -> Identity (HashMap Text ServerSettings))
-> Configuration -> Identity Configuration
Lens' Configuration (HashMap Text ServerSettings)
configServers    ((HashMap Text ServerSettings
  -> Identity (HashMap Text ServerSettings))
 -> Configuration -> Identity Configuration)
-> ((ServerSettings -> Identity ServerSettings)
    -> HashMap Text ServerSettings
    -> Identity (HashMap Text ServerSettings))
-> ASetter
     Configuration Configuration ServerSettings ServerSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerSettings -> Identity ServerSettings)
-> HashMap Text ServerSettings
-> Identity (HashMap Text ServerSettings)
Setter
  (HashMap Text ServerSettings)
  (HashMap Text ServerSettings)
  ServerSettings
  ServerSettings
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ServerSettings -> ServerSettings
resolveServerFilePaths

configurationSpec ::
  ValueSpec (ServerSettings -> Configuration)
configurationSpec :: ValueSpec (ServerSettings -> Configuration)
configurationSpec = Text
-> SectionsSpec (ServerSettings -> Configuration)
-> ValueSpec (ServerSettings -> Configuration)
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"config-file" (SectionsSpec (ServerSettings -> Configuration)
 -> ValueSpec (ServerSettings -> Configuration))
-> SectionsSpec (ServerSettings -> Configuration)
-> ValueSpec (ServerSettings -> Configuration)
forall a b. (a -> b) -> a -> b
$

  do let sec' :: b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' b
def Text
name ValueSpec b
spec Text
info = b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe b
def (Maybe b -> b) -> SectionsSpec (Maybe b) -> SectionsSpec b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ValueSpec b -> Text -> SectionsSpec (Maybe b)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
name ValueSpec b
spec Text
info

     (Maybe Text, ServerSettings -> ServerSettings)
ssDefUpdate            <- (Maybe Text, ServerSettings -> ServerSettings)
-> Text
-> ValueSpec (Maybe Text, ServerSettings -> ServerSettings)
-> Text
-> SectionsSpec (Maybe Text, ServerSettings -> ServerSettings)
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' (Maybe Text
forall a. Maybe a
Nothing,ServerSettings -> ServerSettings
forall a. a -> a
id) Text
"defaults" ValueSpec (Maybe Text, ServerSettings -> ServerSettings)
serverSpec
                               Text
"Default values for use across all server configurations"
     [(Maybe Text, ServerSettings -> ServerSettings)]
ssUpdates              <- [(Maybe Text, ServerSettings -> ServerSettings)]
-> Text
-> ValueSpec [(Maybe Text, ServerSettings -> ServerSettings)]
-> Text
-> SectionsSpec [(Maybe Text, ServerSettings -> ServerSettings)]
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [] Text
"servers" (ValueSpec (Maybe Text, ServerSettings -> ServerSettings)
-> ValueSpec [(Maybe Text, ServerSettings -> ServerSettings)]
forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec (Maybe Text, ServerSettings -> ServerSettings)
serverSpec)
                               Text
"Configuration parameters for IRC servers"
     Palette
_configPalette         <- Palette
-> Text -> ValueSpec Palette -> Text -> SectionsSpec Palette
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' Palette
defaultPalette Text
"palette" ValueSpec Palette
paletteSpec
                               Text
"Customize the client color choices"
     Text
_configWindowNames     <- Text -> Text -> ValueSpec Text -> Text -> SectionsSpec Text
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' Text
defaultWindowNames Text
"window-names" ValueSpec Text
forall a. HasSpec a => ValueSpec a
anySpec
                               Text
"Window names to use for quick jumping with jump-modifier key"
     [Modifier]
_configJumpModifier    <- [Modifier]
-> Text -> ValueSpec [Modifier] -> Text -> SectionsSpec [Modifier]
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [Modifier
MMeta] Text
"jump-modifier" ValueSpec [Modifier]
modifierSpec
                               Text
"Modifier used to jump to a window by name. Defaults to `meta`."
     Recognizer Macro
_configMacros          <- Recognizer Macro
-> Text
-> ValueSpec (Recognizer Macro)
-> Text
-> SectionsSpec (Recognizer Macro)
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' Recognizer Macro
forall a. Monoid a => a
mempty Text
"macros" ValueSpec (Recognizer Macro)
macroMapSpec
                               Text
"Programmable macro commands"
     [ExtensionConfiguration]
_configExtensions      <- [ExtensionConfiguration]
-> Text
-> ValueSpec [ExtensionConfiguration]
-> Text
-> SectionsSpec [ExtensionConfiguration]
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [] Text
"extensions" (ValueSpec ExtensionConfiguration
-> ValueSpec [ExtensionConfiguration]
forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec ExtensionConfiguration
extensionSpec)
                               Text
"extension libraries to load at startup"
     Maybe UrlOpener
_configUrlOpener       <- Text
-> ValueSpec UrlOpener -> Text -> SectionsSpec (Maybe UrlOpener)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"url-opener" ValueSpec UrlOpener
urlOpenerSpec
                               Text
"External command used by /url command"
     [Identifier]
_configExtraHighlights <- [Identifier]
-> Text
-> ValueSpec [Identifier]
-> Text
-> SectionsSpec [Identifier]
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [Identifier]
forall a. Monoid a => a
mempty Text
"extra-highlights" (ValueSpec Identifier -> ValueSpec [Identifier]
forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec Identifier
identifierSpec)
                               Text
"Extra words to highlight in chat messages"
     [Identifier]
_configNeverHighlights <- [Identifier]
-> Text
-> ValueSpec [Identifier]
-> Text
-> SectionsSpec [Identifier]
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [Identifier]
forall a. Monoid a => a
mempty Text
"never-highlights" (ValueSpec Identifier -> ValueSpec [Identifier]
forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec Identifier
identifierSpec)
                               Text
"Words to avoid highlighting in chat messages"
     PaddingMode
_configNickPadding     <- PaddingMode
-> Text
-> ValueSpec PaddingMode
-> Text
-> SectionsSpec PaddingMode
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' PaddingMode
NoPadding Text
"nick-padding" ValueSpec PaddingMode
nickPaddingSpec
                               Text
"Amount of space to reserve for nicknames in chat messages"
     [Text]
_configIgnores         <- [Text] -> Text -> ValueSpec [Text] -> Text -> SectionsSpec [Text]
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [] Text
"ignores" ValueSpec [Text]
forall a. HasSpec a => ValueSpec a
anySpec
                               Text
"Set of nicknames to ignore on startup"
     Bool
_configActivityBar     <- Bool -> Text -> ValueSpec Bool -> Text -> SectionsSpec Bool
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' Bool
False  Text
"activity-bar" ValueSpec Bool
yesOrNoSpec
                               Text
"Show channel names and message counts for activity on\
                               \ unfocused channels."
     Bool
_configBellOnMention   <- Bool -> Text -> ValueSpec Bool -> Text -> SectionsSpec Bool
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' Bool
False  Text
"bell-on-mention" ValueSpec Bool
yesOrNoSpec
                               Text
"Emit bell character to terminal on mention"
     Bool
_configHideMeta        <- Bool -> Text -> ValueSpec Bool -> Text -> SectionsSpec Bool
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' Bool
False  Text
"hide-metadata" ValueSpec Bool
yesOrNoSpec
                               Text
"Initial setting for hiding metadata on new windows"
     [KeyMap -> KeyMap]
bindings               <- [KeyMap -> KeyMap]
-> Text
-> ValueSpec [KeyMap -> KeyMap]
-> Text
-> SectionsSpec [KeyMap -> KeyMap]
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [] Text
"key-bindings" (ValueSpec (KeyMap -> KeyMap) -> ValueSpec [KeyMap -> KeyMap]
forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec (KeyMap -> KeyMap)
keyBindingSpec)
                               Text
"Extra key bindings"
     LayoutMode
_configLayout          <- LayoutMode
-> Text -> ValueSpec LayoutMode -> Text -> SectionsSpec LayoutMode
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' LayoutMode
OneColumn Text
"layout" ValueSpec LayoutMode
layoutSpec
                               Text
"Initial setting for window layout"
     Bool
_configShowPing        <- Bool -> Text -> ValueSpec Bool -> Text -> SectionsSpec Bool
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' Bool
True Text
"show-ping" ValueSpec Bool
yesOrNoSpec
                               Text
"Initial setting for visibility of ping times"
     Map Digraph Text
_configDigraphs        <- Map Digraph Text
-> Text
-> ValueSpec (Map Digraph Text)
-> Text
-> SectionsSpec (Map Digraph Text)
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' Map Digraph Text
forall a. Monoid a => a
mempty Text
"extra-digraphs" ([(Digraph, Text)] -> Map Digraph Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Digraph, Text)] -> Map Digraph Text)
-> ValueSpec [(Digraph, Text)] -> ValueSpec (Map Digraph Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec (Digraph, Text) -> ValueSpec [(Digraph, Text)]
forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec (Digraph, Text)
digraphSpec)
                               Text
"Extra digraphs"
     NotifyWith
_configNotifications   <- NotifyWith
-> Text -> ValueSpec NotifyWith -> Text -> SectionsSpec NotifyWith
forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' NotifyWith
notifyWithDefault Text
"notifications" ValueSpec NotifyWith
notifySpec
                               Text
"Whether and how to show desktop notifications"
     return (\ServerSettings
def ->
             let _configDefaults :: ServerSettings
_configDefaults = (Maybe Text, ServerSettings -> ServerSettings)
-> ServerSettings -> ServerSettings
forall a b. (a, b) -> b
snd (Maybe Text, ServerSettings -> ServerSettings)
ssDefUpdate ServerSettings
def
                 _configServers :: HashMap Text ServerSettings
_configServers  = ServerSettings
-> [(Maybe Text, ServerSettings -> ServerSettings)]
-> HashMap Text ServerSettings
buildServerMap ServerSettings
_configDefaults [(Maybe Text, ServerSettings -> ServerSettings)]
ssUpdates
                 _configKeyMap :: KeyMap
_configKeyMap   = (KeyMap -> (KeyMap -> KeyMap) -> KeyMap)
-> KeyMap -> [KeyMap -> KeyMap] -> KeyMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\KeyMap
acc KeyMap -> KeyMap
f -> KeyMap -> KeyMap
f KeyMap
acc) KeyMap
initialKeyMap [KeyMap -> KeyMap]
bindings
             in Configuration{Bool
[Text]
[Identifier]
[Modifier]
[ExtensionConfiguration]
Maybe UrlOpener
Text
Map Digraph Text
HashMap Text ServerSettings
Recognizer Macro
NotifyWith
KeyMap
Palette
ServerSettings
LayoutMode
PaddingMode
_configServers :: HashMap Text ServerSettings
_configDefaults :: ServerSettings
_configPalette :: Palette
_configWindowNames :: Text
_configExtraHighlights :: [Identifier]
_configNeverHighlights :: [Identifier]
_configNickPadding :: PaddingMode
_configMacros :: Recognizer Macro
_configExtensions :: [ExtensionConfiguration]
_configUrlOpener :: Maybe UrlOpener
_configIgnores :: [Text]
_configActivityBar :: Bool
_configBellOnMention :: Bool
_configHideMeta :: Bool
_configKeyMap :: KeyMap
_configLayout :: LayoutMode
_configShowPing :: Bool
_configJumpModifier :: [Modifier]
_configDigraphs :: Map Digraph Text
_configNotifications :: NotifyWith
_configPalette :: Palette
_configWindowNames :: Text
_configJumpModifier :: [Modifier]
_configMacros :: Recognizer Macro
_configExtensions :: [ExtensionConfiguration]
_configUrlOpener :: Maybe UrlOpener
_configExtraHighlights :: [Identifier]
_configNeverHighlights :: [Identifier]
_configNickPadding :: PaddingMode
_configIgnores :: [Text]
_configActivityBar :: Bool
_configBellOnMention :: Bool
_configHideMeta :: Bool
_configLayout :: LayoutMode
_configShowPing :: Bool
_configDigraphs :: Map Digraph Text
_configNotifications :: NotifyWith
_configDefaults :: ServerSettings
_configServers :: HashMap Text ServerSettings
_configKeyMap :: KeyMap
..})

-- | The default nick padding side if padding is going to be used
defaultPaddingSide :: Int -> PaddingMode
defaultPaddingSide :: Int -> PaddingMode
defaultPaddingSide = Int -> PaddingMode
RightPadding

-- | Either full or abbreviated nick-padding configuration
--
-- > nick-padding: 10
--
-- > nick-padding:
-- >   side: right
-- >   width: 16
nickPaddingSpec :: ValueSpec PaddingMode
nickPaddingSpec :: ValueSpec PaddingMode
nickPaddingSpec = Int -> PaddingMode
defaultPaddingSide (Int -> PaddingMode) -> ValueSpec Int -> ValueSpec PaddingMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec Int
forall a. (Ord a, Num a) => ValueSpec a
nonnegativeSpec ValueSpec PaddingMode
-> ValueSpec PaddingMode -> ValueSpec PaddingMode
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec PaddingMode
fullNickPaddingSpec

-- | Full nick padding specification:
--
-- > nick-padding:
-- >   side: left
-- >   width: 15
fullNickPaddingSpec :: ValueSpec PaddingMode
fullNickPaddingSpec :: ValueSpec PaddingMode
fullNickPaddingSpec = Text -> SectionsSpec PaddingMode -> ValueSpec PaddingMode
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"nick-padding" (SectionsSpec (Int -> PaddingMode)
sideSec SectionsSpec (Int -> PaddingMode)
-> SectionsSpec Int -> SectionsSpec PaddingMode
forall a b.
SectionsSpec (a -> b) -> SectionsSpec a -> SectionsSpec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SectionsSpec Int
amtSec)
  where
    sideSpec :: ValueSpec (Int -> PaddingMode)
sideSpec = Int -> PaddingMode
LeftPadding  (Int -> PaddingMode)
-> ValueSpec () -> ValueSpec (Int -> PaddingMode)
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"left" ValueSpec (Int -> PaddingMode)
-> ValueSpec (Int -> PaddingMode) -> ValueSpec (Int -> PaddingMode)
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!>
               Int -> PaddingMode
RightPadding (Int -> PaddingMode)
-> ValueSpec () -> ValueSpec (Int -> PaddingMode)
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"right"

    sideSec :: SectionsSpec (Int -> PaddingMode)
sideSec = (Int -> PaddingMode)
-> Maybe (Int -> PaddingMode) -> Int -> PaddingMode
forall a. a -> Maybe a -> a
fromMaybe Int -> PaddingMode
defaultPaddingSide
          (Maybe (Int -> PaddingMode) -> Int -> PaddingMode)
-> SectionsSpec (Maybe (Int -> PaddingMode))
-> SectionsSpec (Int -> PaddingMode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ValueSpec (Int -> PaddingMode)
-> Text
-> SectionsSpec (Maybe (Int -> PaddingMode))
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"side" ValueSpec (Int -> PaddingMode)
sideSpec Text
"Side to pad (default `right`)"

    amtSec :: SectionsSpec Int
amtSec  = Text -> ValueSpec Int -> Text -> SectionsSpec Int
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"width" ValueSpec Int
forall a. (Ord a, Num a) => ValueSpec a
nonnegativeSpec Text
"Field width"


-- | Parse either a single modifier key or a list of modifier keys:
-- @meta@, @alt@, @ctrl@
modifierSpec :: ValueSpec [Modifier]
modifierSpec :: ValueSpec [Modifier]
modifierSpec = NonEmpty Modifier -> [Modifier]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Modifier -> [Modifier])
-> ValueSpec (NonEmpty Modifier) -> ValueSpec [Modifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec Modifier -> ValueSpec (NonEmpty Modifier)
forall a. ValueSpec a -> ValueSpec (NonEmpty a)
oneOrNonemptySpec ValueSpec Modifier
modifier1Spec
  where
    modifier1Spec :: ValueSpec Modifier
modifier1Spec = Text -> ValueSpec Modifier -> ValueSpec Modifier
forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"modifier"
                  (ValueSpec Modifier -> ValueSpec Modifier)
-> ValueSpec Modifier -> ValueSpec Modifier
forall a b. (a -> b) -> a -> b
$ Modifier
MMeta Modifier -> ValueSpec () -> ValueSpec Modifier
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"meta"
                ValueSpec Modifier -> ValueSpec Modifier -> ValueSpec Modifier
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Modifier
MAlt  Modifier -> ValueSpec () -> ValueSpec Modifier
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"alt"
                ValueSpec Modifier -> ValueSpec Modifier -> ValueSpec Modifier
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Modifier
MCtrl Modifier -> ValueSpec () -> ValueSpec Modifier
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"ctrl"

-- | Parse either @one-column@ or @two-column@ and return the corresponding
-- 'LayoutMode' value.
layoutSpec :: ValueSpec LayoutMode
layoutSpec :: ValueSpec LayoutMode
layoutSpec = LayoutMode
OneColumn LayoutMode -> ValueSpec () -> ValueSpec LayoutMode
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"one-column"
         ValueSpec LayoutMode
-> ValueSpec LayoutMode -> ValueSpec LayoutMode
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> LayoutMode
TwoColumn LayoutMode -> ValueSpec () -> ValueSpec LayoutMode
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"two-column"

-- | Parse a single key binding. This can be an action binding, command
-- binding, or an unbinding specification.
keyBindingSpec :: ValueSpec (KeyMap -> KeyMap)
keyBindingSpec :: ValueSpec (KeyMap -> KeyMap)
keyBindingSpec = ValueSpec (KeyMap -> KeyMap)
actBindingSpec ValueSpec (KeyMap -> KeyMap)
-> ValueSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap)
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec (KeyMap -> KeyMap)
cmdBindingSpec ValueSpec (KeyMap -> KeyMap)
-> ValueSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap)
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec (KeyMap -> KeyMap)
unbindingSpec

-- | Parse a single action key binding. Action bindings are a map specifying
-- a binding using 'keySpec' and an action:
--
-- > bind: "M-a"
-- > action: jump-to-activity
actBindingSpec :: ValueSpec (KeyMap -> KeyMap)
actBindingSpec :: ValueSpec (KeyMap -> KeyMap)
actBindingSpec = Text
-> SectionsSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap)
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"action-binding" (SectionsSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap))
-> SectionsSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap)
forall a b. (a -> b) -> a -> b
$
  do ~([Modifier]
m,Key
k) <- Text
-> ValueSpec ([Modifier], Key)
-> Text
-> SectionsSpec ([Modifier], Key)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"bind" ValueSpec ([Modifier], Key)
keySpec
               Text
"Key to be bound (e.g. \"a\", \"C-b\", \"M-c\", \"C-M-d\")"
     Action
a      <- Text -> Text -> SectionsSpec Action
forall a. HasSpec a => Text -> Text -> SectionsSpec a
reqSection Text
"action"
               Text
"Action name (see `/keymap`)"
     return ([Modifier] -> Key -> Action -> KeyMap -> KeyMap
addKeyBinding [Modifier]
m Key
k Action
a)

cmdBindingSpec :: ValueSpec (KeyMap -> KeyMap)
cmdBindingSpec :: ValueSpec (KeyMap -> KeyMap)
cmdBindingSpec = Text
-> SectionsSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap)
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"command-binding" (SectionsSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap))
-> SectionsSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap)
forall a b. (a -> b) -> a -> b
$
  do ~([Modifier]
m,Key
k) <- Text
-> ValueSpec ([Modifier], Key)
-> Text
-> SectionsSpec ([Modifier], Key)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"bind" ValueSpec ([Modifier], Key)
keySpec
               Text
"Key to be bound (e.g. \"a\", \"C-b\", \"M-c\", \"C-M-d\")"
     Text
cmd    <- Text -> Text -> SectionsSpec Text
forall a. HasSpec a => Text -> Text -> SectionsSpec a
reqSection Text
"command"
               Text
"Client command to execute (exclude leading `/`)"
     return ([Modifier] -> Key -> Action -> KeyMap -> KeyMap
addKeyBinding [Modifier]
m Key
k (Text -> Action
ActCommand Text
cmd))

unbindingSpec :: ValueSpec (KeyMap -> KeyMap)
unbindingSpec :: ValueSpec (KeyMap -> KeyMap)
unbindingSpec = Text
-> SectionsSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap)
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"remove-binding" (SectionsSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap))
-> SectionsSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap)
forall a b. (a -> b) -> a -> b
$
  do ~([Modifier]
m,Key
k) <- Text
-> ValueSpec ([Modifier], Key)
-> Text
-> SectionsSpec ([Modifier], Key)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"unbind" ValueSpec ([Modifier], Key)
keySpec
               Text
"Key to be unbound (e.g. \"a\", \"C-b\", \"M-c\", \"C-M-d\")"
     return ([Modifier] -> Key -> KeyMap -> KeyMap
removeKeyBinding [Modifier]
m Key
k)


-- | Custom configuration specification for emacs-style key descriptions
keySpec :: ValueSpec ([Modifier], Key)
keySpec :: ValueSpec ([Modifier], Key)
keySpec = Text
-> ValueSpec FilePath
-> (FilePath -> Either Text ([Modifier], Key))
-> ValueSpec ([Modifier], Key)
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"emacs-key" ValueSpec FilePath
stringSpec
        ((FilePath -> Either Text ([Modifier], Key))
 -> ValueSpec ([Modifier], Key))
-> (FilePath -> Either Text ([Modifier], Key))
-> ValueSpec ([Modifier], Key)
forall a b. (a -> b) -> a -> b
$ \FilePath
key -> case FilePath -> Maybe ([Modifier], Key)
parseKey FilePath
key of
                    Maybe ([Modifier], Key)
Nothing -> Text -> Either Text ([Modifier], Key)
forall a b. a -> Either a b
Left Text
"unknown key"
                    Just ([Modifier], Key)
x  -> ([Modifier], Key) -> Either Text ([Modifier], Key)
forall a b. b -> Either a b
Right ([Modifier], Key)
x


nonnegativeSpec :: (Ord a, Num a) => ValueSpec a
nonnegativeSpec :: forall a. (Ord a, Num a) => ValueSpec a
nonnegativeSpec = Text -> ValueSpec a -> (a -> Either Text a) -> ValueSpec a
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"non-negative" ValueSpec a
forall a. Num a => ValueSpec a
numSpec
                ((a -> Either Text a) -> ValueSpec a)
-> (a -> Either Text a) -> ValueSpec a
forall a b. (a -> b) -> a -> b
$ \a
x -> if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then Text -> Either Text a
forall a b. a -> Either a b
Left Text
"negative number"
                                 else a -> Either Text a
forall a b. b -> Either a b
Right a
x


paletteSpec :: ValueSpec Palette
paletteSpec :: ValueSpec Palette
paletteSpec = Text -> SectionsSpec Palette -> ValueSpec Palette
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"palette" (SectionsSpec Palette -> ValueSpec Palette)
-> SectionsSpec Palette -> ValueSpec Palette
forall a b. (a -> b) -> a -> b
$
  ((Unwrapped (Endo Palette) -> Endo Palette)
-> ((Unwrapped (Endo Palette) -> Endo Palette)
    -> [Maybe (Palette -> Palette)] -> Endo Palette)
-> [Maybe (Palette -> Palette)]
-> Unwrapped (Endo Palette)
forall (f :: * -> *) s t.
(Functor f, Rewrapping s t) =>
(Unwrapped s -> s)
-> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s)
ala Unwrapped (Endo Palette) -> Endo Palette
(Palette -> Palette) -> Endo Palette
forall a. (a -> a) -> Endo a
Endo ((Maybe (Unwrapped (Endo Palette)) -> Endo Palette)
-> [Maybe (Unwrapped (Endo Palette))] -> Endo Palette
(Maybe (Unwrapped (Endo Palette)) -> Endo Palette)
-> [Maybe (Palette -> Palette)] -> Endo Palette
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Maybe (Unwrapped (Endo Palette)) -> Endo Palette)
 -> [Maybe (Palette -> Palette)] -> Endo Palette)
-> ((Unwrapped (Endo Palette) -> Endo Palette)
    -> Maybe (Unwrapped (Endo Palette)) -> Endo Palette)
-> (Unwrapped (Endo Palette) -> Endo Palette)
-> [Maybe (Palette -> Palette)]
-> Endo Palette
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unwrapped (Endo Palette) -> Endo Palette)
-> Maybe (Unwrapped (Endo Palette)) -> Endo Palette
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) ([Maybe (Palette -> Palette)] -> Palette -> Palette)
-> Palette -> [Maybe (Palette -> Palette)] -> Palette
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? Palette
defaultPalette) ([Maybe (Palette -> Palette)] -> Palette)
-> SectionsSpec [Maybe (Palette -> Palette)]
-> SectionsSpec Palette
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SectionsSpec (Maybe (Palette -> Palette))]
-> SectionsSpec [Maybe (Palette -> Palette)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA [SectionsSpec (Maybe (Palette -> Palette))]
fields

  where
    nickColorsSpec :: ValueSpec (Palette -> Palette)
    nickColorsSpec :: ValueSpec (Palette -> Palette)
nickColorsSpec = ASetter Palette Palette (Vector Attr) (Vector Attr)
-> Vector Attr -> Palette -> Palette
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Palette Palette (Vector Attr) (Vector Attr)
Lens' Palette (Vector Attr)
palNicks (Vector Attr -> Palette -> Palette)
-> (NonEmpty Attr -> Vector Attr)
-> NonEmpty Attr
-> Palette
-> Palette
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attr] -> Vector Attr
forall a. [a] -> Vector a
Vector.fromList ([Attr] -> Vector Attr)
-> (NonEmpty Attr -> [Attr]) -> NonEmpty Attr -> Vector Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Attr -> [Attr]
forall a. NonEmpty a -> [a]
NonEmpty.toList
                 (NonEmpty Attr -> Palette -> Palette)
-> ValueSpec (NonEmpty Attr) -> ValueSpec (Palette -> Palette)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec Attr -> ValueSpec (NonEmpty Attr)
forall a. ValueSpec a -> ValueSpec (NonEmpty a)
nonemptySpec ValueSpec Attr
attrSpec

    idOverridesSpec :: ValueSpec (Palette -> Palette)
idOverridesSpec = ASetter
  Palette Palette (HashMap Identifier Attr) (HashMap Identifier Attr)
-> HashMap Identifier Attr -> Palette -> Palette
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Palette Palette (HashMap Identifier Attr) (HashMap Identifier Attr)
Lens' Palette (HashMap Identifier Attr)
palIdOverride (HashMap Identifier Attr -> Palette -> Palette)
-> ([[(Identifier, Attr)]] -> HashMap Identifier Attr)
-> [[(Identifier, Attr)]]
-> Palette
-> Palette
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Identifier, Attr)] -> HashMap Identifier Attr
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Identifier, Attr)] -> HashMap Identifier Attr)
-> ([[(Identifier, Attr)]] -> [(Identifier, Attr)])
-> [[(Identifier, Attr)]]
-> HashMap Identifier Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Identifier, Attr)]] -> [(Identifier, Attr)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Identifier, Attr)]] -> Palette -> Palette)
-> ValueSpec [[(Identifier, Attr)]]
-> ValueSpec (Palette -> Palette)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec [(Identifier, Attr)] -> ValueSpec [[(Identifier, Attr)]]
forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec [(Identifier, Attr)]
idOverrideSpec
    idOverrideSpec :: ValueSpec [(Identifier, Attr)]
idOverrideSpec =
      Text
-> SectionsSpec [(Identifier, Attr)]
-> ValueSpec [(Identifier, Attr)]
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"ids-to-attr" (SectionsSpec [(Identifier, Attr)]
 -> ValueSpec [(Identifier, Attr)])
-> SectionsSpec [(Identifier, Attr)]
-> ValueSpec [(Identifier, Attr)]
forall a b. (a -> b) -> a -> b
$
      do [FilePath]
ids <- Text -> ValueSpec [FilePath] -> Text -> SectionsSpec [FilePath]
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"ids" (ValueSpec FilePath -> ValueSpec [FilePath]
forall a. ValueSpec a -> ValueSpec [a]
oneOrList ValueSpec FilePath
stringSpec) Text
"One or more identifiers that this override applies to."
         Attr
attr <- Text -> ValueSpec Attr -> Text -> SectionsSpec Attr
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"color" ValueSpec Attr
attrSpec Text
"The style to use."
         pure [(Text -> Identifier
mkId (Text -> Identifier) -> Text -> Identifier
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack FilePath
id', Attr
attr) | FilePath
id' <- [FilePath]
ids]

    fields :: [SectionsSpec (Maybe (Palette -> Palette))]
    fields :: [SectionsSpec (Maybe (Palette -> Palette))]
fields = Text
-> ValueSpec (Palette -> Palette)
-> Text
-> SectionsSpec (Maybe (Palette -> Palette))
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"identifier-colors" ValueSpec (Palette -> Palette)
nickColorsSpec
             Text
"Colors used to highlight identifiers (nicks, channel names)."
           SectionsSpec (Maybe (Palette -> Palette))
-> [SectionsSpec (Maybe (Palette -> Palette))]
-> [SectionsSpec (Maybe (Palette -> Palette))]
forall a. a -> [a] -> [a]
: Text
-> ValueSpec (Palette -> Palette)
-> Text
-> SectionsSpec (Maybe (Palette -> Palette))
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"identifier-overrides" ValueSpec (Palette -> Palette)
idOverridesSpec
             Text
"Colors used to highlight specific identifiers (nicks, channel names)."
           SectionsSpec (Maybe (Palette -> Palette))
-> [SectionsSpec (Maybe (Palette -> Palette))]
-> [SectionsSpec (Maybe (Palette -> Palette))]
forall a. a -> [a] -> [a]
: [ Text
-> ValueSpec (Palette -> Palette)
-> Text
-> SectionsSpec (Maybe (Palette -> Palette))
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
lbl (ASetter Palette Palette Attr Attr -> Attr -> Palette -> Palette
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Palette Palette Attr Attr
Lens Palette Palette Attr Attr
l (Attr -> Palette -> Palette)
-> ValueSpec Attr -> ValueSpec (Palette -> Palette)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec Attr
attrSpec) Text
"" | (Text
lbl, Lens Lens Palette Palette Attr Attr
l) <- [(Text, ReifiedLens' Palette Attr)]
paletteMap ]

extensionSpec :: ValueSpec ExtensionConfiguration
extensionSpec :: ValueSpec ExtensionConfiguration
extensionSpec = ValueSpec ExtensionConfiguration
simpleExtensionSpec ValueSpec ExtensionConfiguration
-> ValueSpec ExtensionConfiguration
-> ValueSpec ExtensionConfiguration
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec ExtensionConfiguration
fullExtensionSpec

-- | Default dynamic linker flags: @RTLD_LOCAL@ and @RTLD_NOW@
defaultRtldFlags :: [RTLDFlags]
defaultRtldFlags :: [RTLDFlags]
defaultRtldFlags = [RTLDFlags
RTLD_LOCAL, RTLDFlags
RTLD_NOW]

-- | Given only a filepath build an extension configuration that
-- loads the extension using the 'defaultRtldFlags' and no arguments.
simpleExtensionSpec :: ValueSpec ExtensionConfiguration
simpleExtensionSpec :: ValueSpec ExtensionConfiguration
simpleExtensionSpec =
  do FilePath
_extensionPath <- ValueSpec FilePath
stringSpec
     pure ExtensionConfiguration
       { _extensionRtldFlags :: [RTLDFlags]
_extensionRtldFlags = [RTLDFlags]
defaultRtldFlags
       , _extensionArgs :: [Text]
_extensionArgs      = []
       , FilePath
_extensionPath :: FilePath
_extensionPath :: FilePath
.. }

-- | Full extension configuration allows the RTLD flags to be manually
-- specified. This can be useful if the extension defines symbols that
-- need to be visible to libraries that the extension is linked against.
fullExtensionSpec :: ValueSpec ExtensionConfiguration
fullExtensionSpec :: ValueSpec ExtensionConfiguration
fullExtensionSpec =
  Text
-> SectionsSpec ExtensionConfiguration
-> ValueSpec ExtensionConfiguration
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"extension" (SectionsSpec ExtensionConfiguration
 -> ValueSpec ExtensionConfiguration)
-> SectionsSpec ExtensionConfiguration
-> ValueSpec ExtensionConfiguration
forall a b. (a -> b) -> a -> b
$
  do FilePath
_extensionPath      <- Text -> ValueSpec FilePath -> Text -> SectionsSpec FilePath
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"path"       ValueSpec FilePath
stringSpec
                            Text
"Path to shared object"
     [RTLDFlags]
_extensionRtldFlags <- [RTLDFlags] -> Maybe [RTLDFlags] -> [RTLDFlags]
forall a. a -> Maybe a -> a
fromMaybe [RTLDFlags]
defaultRtldFlags (Maybe [RTLDFlags] -> [RTLDFlags])
-> SectionsSpec (Maybe [RTLDFlags]) -> SectionsSpec [RTLDFlags]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            Text
-> ValueSpec [RTLDFlags]
-> Text
-> SectionsSpec (Maybe [RTLDFlags])
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"rtld-flags" (ValueSpec RTLDFlags -> ValueSpec [RTLDFlags]
forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec RTLDFlags
rtldFlagSpec)
                            Text
"Runtime dynamic linker flags"
     [Text]
_extensionArgs      <- [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text])
-> SectionsSpec (Maybe [Text]) -> SectionsSpec [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> SectionsSpec (Maybe [Text])
forall a. HasSpec a => Text -> Text -> SectionsSpec (Maybe a)
optSection Text
"args"
                            Text
"Extension-specific configuration arguments"
     pure ExtensionConfiguration {FilePath
[Text]
[RTLDFlags]
_extensionPath :: FilePath
_extensionRtldFlags :: [RTLDFlags]
_extensionArgs :: [Text]
_extensionPath :: FilePath
_extensionRtldFlags :: [RTLDFlags]
_extensionArgs :: [Text]
..}

rtldFlagSpec :: ValueSpec RTLDFlags
rtldFlagSpec :: ValueSpec RTLDFlags
rtldFlagSpec = Text -> ValueSpec RTLDFlags -> ValueSpec RTLDFlags
forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"rtld-flag"
             (ValueSpec RTLDFlags -> ValueSpec RTLDFlags)
-> ValueSpec RTLDFlags -> ValueSpec RTLDFlags
forall a b. (a -> b) -> a -> b
$ RTLDFlags
RTLD_LOCAL  RTLDFlags -> ValueSpec () -> ValueSpec RTLDFlags
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"local"
           ValueSpec RTLDFlags -> ValueSpec RTLDFlags -> ValueSpec RTLDFlags
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> RTLDFlags
RTLD_GLOBAL RTLDFlags -> ValueSpec () -> ValueSpec RTLDFlags
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"global"
           ValueSpec RTLDFlags -> ValueSpec RTLDFlags -> ValueSpec RTLDFlags
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> RTLDFlags
RTLD_NOW    RTLDFlags -> ValueSpec () -> ValueSpec RTLDFlags
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"now"
           ValueSpec RTLDFlags -> ValueSpec RTLDFlags -> ValueSpec RTLDFlags
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> RTLDFlags
RTLD_LAZY   RTLDFlags -> ValueSpec () -> ValueSpec RTLDFlags
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"lazy"

urlOpenerSpec :: ValueSpec UrlOpener
urlOpenerSpec :: ValueSpec UrlOpener
urlOpenerSpec = ValueSpec UrlOpener
simpleCase ValueSpec UrlOpener -> ValueSpec UrlOpener -> ValueSpec UrlOpener
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec UrlOpener
complexCase
  where
    simpleCase :: ValueSpec UrlOpener
simpleCase =
      do FilePath
path <- ValueSpec FilePath
stringSpec
         pure (FilePath -> [UrlArgument] -> UrlOpener
UrlOpener FilePath
path [UrlArgument
UrlArgUrl])

    complexCase :: ValueSpec UrlOpener
complexCase = Text -> SectionsSpec UrlOpener -> ValueSpec UrlOpener
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"url-opener" (SectionsSpec UrlOpener -> ValueSpec UrlOpener)
-> SectionsSpec UrlOpener -> ValueSpec UrlOpener
forall a b. (a -> b) -> a -> b
$
      do FilePath
path <- Text -> ValueSpec FilePath -> Text -> SectionsSpec FilePath
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"path" ValueSpec FilePath
stringSpec Text
"Executable"
         [UrlArgument]
args <- Text
-> ValueSpec [UrlArgument] -> Text -> SectionsSpec [UrlArgument]
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"args" (ValueSpec UrlArgument -> ValueSpec [UrlArgument]
forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec UrlArgument
argSpec) Text
"Arguments"
         pure (FilePath -> [UrlArgument] -> UrlOpener
UrlOpener FilePath
path [UrlArgument]
args)

    argSpec :: ValueSpec UrlArgument
argSpec = UrlArgument
UrlArgUrl     UrlArgument -> ValueSpec () -> ValueSpec UrlArgument
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Text -> ValueSpec ()
atomSpec Text
"url"
          ValueSpec UrlArgument
-> ValueSpec UrlArgument -> ValueSpec UrlArgument
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> FilePath -> UrlArgument
UrlArgLiteral (FilePath -> UrlArgument)
-> ValueSpec FilePath -> ValueSpec UrlArgument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec FilePath
stringSpec

digraphSpec :: ValueSpec (Digraph, Text)
digraphSpec :: ValueSpec (Digraph, Text)
digraphSpec =
  Text -> SectionsSpec (Digraph, Text) -> ValueSpec (Digraph, Text)
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"digraph" (SectionsSpec (Digraph, Text) -> ValueSpec (Digraph, Text))
-> SectionsSpec (Digraph, Text) -> ValueSpec (Digraph, Text)
forall a b. (a -> b) -> a -> b
$
   do ~(Char
x,Char
y) <- Text -> ValueSpec (Char, Char) -> Text -> SectionsSpec (Char, Char)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"input" ValueSpec (Char, Char)
twoChars Text
"digraph key"
      Text
val    <- Text -> ValueSpec Text -> Text -> SectionsSpec Text
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"output" ValueSpec Text
textSpec Text
"replacement text"
      pure (Char -> Char -> Digraph
Digraph Char
x Char
y, Text
val)
  where
    twoChars :: ValueSpec (Char, Char)
twoChars = Text
-> ValueSpec FilePath
-> (FilePath -> Either Text (Char, Char))
-> ValueSpec (Char, Char)
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"two" ValueSpec FilePath
stringSpec ((FilePath -> Either Text (Char, Char)) -> ValueSpec (Char, Char))
-> (FilePath -> Either Text (Char, Char)) -> ValueSpec (Char, Char)
forall a b. (a -> b) -> a -> b
$ \case
        [Char
x,Char
y] -> (Char, Char) -> Either Text (Char, Char)
forall a b. b -> Either a b
Right (Char
x,Char
y)
        FilePath
_     -> Text -> Either Text (Char, Char)
forall a b. a -> Either a b
Left Text
"exactly two characters required"

buildServerMap ::
  ServerSettings {- ^ defaults -} ->
  [(Maybe Text, ServerSettings -> ServerSettings)] ->
  HashMap Text ServerSettings
buildServerMap :: ServerSettings
-> [(Maybe Text, ServerSettings -> ServerSettings)]
-> HashMap Text ServerSettings
buildServerMap ServerSettings
def [(Maybe Text, ServerSettings -> ServerSettings)]
ups = HashMap Text ServerSettings
-> ServerSettings -> Maybe Text -> HashMap Text ServerSettings
go HashMap Text ServerSettings
forall k v. HashMap k v
HashMap.empty ServerSettings
def Maybe Text
forall a. Maybe a
Nothing
  where
    serverSettingName :: ServerSettings -> Text
serverSettingName ServerSettings
ss =
      Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (LensLike' (Const Text) ServerSettings FilePath
-> (FilePath -> Text) -> ServerSettings -> Text
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const Text) ServerSettings FilePath
Lens' ServerSettings FilePath
ssHostName FilePath -> Text
Text.pack ServerSettings
ss)
                (Getting (Maybe Text) ServerSettings (Maybe Text)
-> ServerSettings -> Maybe Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Text) ServerSettings (Maybe Text)
Lens' ServerSettings (Maybe Text)
ssName ServerSettings
ss)

    raw :: HashMap (Maybe Text) [ServerSettings -> ServerSettings]
raw = ([ServerSettings -> ServerSettings]
 -> [ServerSettings -> ServerSettings]
 -> [ServerSettings -> ServerSettings])
-> [(Maybe Text, [ServerSettings -> ServerSettings])]
-> HashMap (Maybe Text) [ServerSettings -> ServerSettings]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith [ServerSettings -> ServerSettings]
-> [ServerSettings -> ServerSettings]
-> [ServerSettings -> ServerSettings]
forall a. [a] -> [a] -> [a]
(++) [(Maybe Text
mbExtName, [ServerSettings -> ServerSettings
up]) | (Maybe Text
mbExtName, ServerSettings -> ServerSettings
up) <- [(Maybe Text, ServerSettings -> ServerSettings)]
ups]

    go :: HashMap Text ServerSettings
-> ServerSettings -> Maybe Text -> HashMap Text ServerSettings
go HashMap Text ServerSettings
acc ServerSettings
prev Maybe Text
prevName = (HashMap Text ServerSettings
 -> (ServerSettings -> ServerSettings)
 -> HashMap Text ServerSettings)
-> HashMap Text ServerSettings
-> [ServerSettings -> ServerSettings]
-> HashMap Text ServerSettings
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (ServerSettings
-> HashMap Text ServerSettings
-> (ServerSettings -> ServerSettings)
-> HashMap Text ServerSettings
add ServerSettings
prev) HashMap Text ServerSettings
acc [ServerSettings -> ServerSettings]
nexts
      where
        nexts :: [ServerSettings -> ServerSettings]
nexts = [ServerSettings -> ServerSettings]
-> Maybe Text
-> HashMap (Maybe Text) [ServerSettings -> ServerSettings]
-> [ServerSettings -> ServerSettings]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.findWithDefault [] Maybe Text
prevName HashMap (Maybe Text) [ServerSettings -> ServerSettings]
raw

    add :: ServerSettings
-> HashMap Text ServerSettings
-> (ServerSettings -> ServerSettings)
-> HashMap Text ServerSettings
add ServerSettings
prev HashMap Text ServerSettings
acc ServerSettings -> ServerSettings
f = HashMap Text ServerSettings
-> ServerSettings -> Maybe Text -> HashMap Text ServerSettings
go HashMap Text ServerSettings
acc' ServerSettings
ss (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
me)
      where
        ss :: ServerSettings
ss = ServerSettings -> ServerSettings
f ServerSettings
prev
        me :: Text
me = ServerSettings -> Text
serverSettingName ServerSettings
ss
        acc' :: HashMap Text ServerSettings
acc'
          | Text -> HashMap Text ServerSettings -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Text
me HashMap Text ServerSettings
acc = HashMap Text ServerSettings
acc
          | Bool
otherwise             = Text
-> ServerSettings
-> HashMap Text ServerSettings
-> HashMap Text ServerSettings
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Text
me ServerSettings
ss HashMap Text ServerSettings
acc

data FilePathContext = FilePathContext { FilePathContext -> FilePath
fpBase, FilePathContext -> FilePath
fpHome :: FilePath }

newFilePathContext ::
  FilePath {- ^ configuration file path -} ->
  IO FilePathContext
newFilePathContext :: FilePath -> IO FilePathContext
newFilePathContext FilePath
base = FilePath -> FilePath -> FilePathContext
FilePathContext (ShowS
takeDirectory FilePath
base) (FilePath -> FilePathContext) -> IO FilePath -> IO FilePathContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getHomeDirectory

resolveFilePath :: FilePathContext -> FilePath -> FilePath
resolveFilePath :: FilePathContext -> ShowS
resolveFilePath FilePathContext
fpc FilePath
path
  | FilePath -> Bool
isAbsolute FilePath
path                   = FilePath
path
  | FilePath
"~":[FilePath]
rest <- FilePath -> [FilePath]
splitDirectories FilePath
path = [FilePath] -> FilePath
joinPath (FilePathContext -> FilePath
fpHome FilePathContext
fpc FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
rest)
  | Bool
otherwise                         = FilePathContext -> FilePath
fpBase FilePathContext
fpc FilePath -> ShowS
</> FilePath
path

-- | Returns a NetworkPalette for the given network name.
configNetworkPalette :: Text -> Configuration -> NetworkPalette
configNetworkPalette :: Text -> Configuration -> NetworkPalette
configNetworkPalette Text
net Configuration
cfg = NetworkPalette -> NetworkPalette -> NetworkPalette
unifyNetworkPalette NetworkPalette
palDefault (NetworkPalette -> NetworkPalette)
-> NetworkPalette -> NetworkPalette
forall a b. (a -> b) -> a -> b
$ NetworkPalette -> Maybe NetworkPalette -> NetworkPalette
forall a. a -> Maybe a -> a
fromMaybe NetworkPalette
defaultNetworkPalette Maybe NetworkPalette
palNet
  where
    palNet :: Maybe NetworkPalette
palNet = Getting NetworkPalette ServerSettings NetworkPalette
-> ServerSettings -> NetworkPalette
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NetworkPalette ServerSettings NetworkPalette
Lens' ServerSettings NetworkPalette
ssPalette (ServerSettings -> NetworkPalette)
-> Maybe ServerSettings -> Maybe NetworkPalette
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe ServerSettings) Configuration (Maybe ServerSettings)
-> Configuration -> Maybe ServerSettings
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((HashMap Text ServerSettings
 -> Const (Maybe ServerSettings) (HashMap Text ServerSettings))
-> Configuration -> Const (Maybe ServerSettings) Configuration
Lens' Configuration (HashMap Text ServerSettings)
configServers ((HashMap Text ServerSettings
  -> Const (Maybe ServerSettings) (HashMap Text ServerSettings))
 -> Configuration -> Const (Maybe ServerSettings) Configuration)
-> ((Maybe ServerSettings
     -> Const (Maybe ServerSettings) (Maybe ServerSettings))
    -> HashMap Text ServerSettings
    -> Const (Maybe ServerSettings) (HashMap Text ServerSettings))
-> Getting
     (Maybe ServerSettings) Configuration (Maybe ServerSettings)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text ServerSettings)
-> Lens'
     (HashMap Text ServerSettings)
     (Maybe (IxValue (HashMap Text ServerSettings)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (HashMap Text ServerSettings)
net) Configuration
cfg
    palDefault :: NetworkPalette
palDefault = Getting NetworkPalette Configuration NetworkPalette
-> Configuration -> NetworkPalette
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ServerSettings -> Const NetworkPalette ServerSettings)
-> Configuration -> Const NetworkPalette Configuration
Lens' Configuration ServerSettings
configDefaults((ServerSettings -> Const NetworkPalette ServerSettings)
 -> Configuration -> Const NetworkPalette Configuration)
-> Getting NetworkPalette ServerSettings NetworkPalette
-> Getting NetworkPalette Configuration NetworkPalette
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting NetworkPalette ServerSettings NetworkPalette
Lens' ServerSettings NetworkPalette
ssPalette) Configuration
cfg