{-# 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

  , 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
import           Client.Commands.Recognizer
import           Client.Configuration.Colors
import           Client.Configuration.Macros (macroMapSpec)
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 qualified Data.HashMap.Strict                 as HashMap
import qualified Data.List.NonEmpty                  as NonEmpty
import           Data.Map                            (Map)
import qualified Data.Map                            as Map
import           Data.Maybe
import           Data.Monoid                         (Endo(..))
import           Data.Text                           (Text)
import qualified Data.Text                           as Text
import qualified Data.Vector                         as Vector
import           Digraphs (Digraph(..))
import           Graphics.Vty.Input.Events (Modifier(..), Key(..))
import           Graphics.Vty.Attributes             (Attr)
import           Irc.Identifier                      (Identifier)
import           System.Directory
import           System.FilePath
import           System.Posix.DynamicLinker          (RTLDFlags(..))
import           System.IO.Error

-- | 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
  }
  deriving Int -> Configuration -> ShowS
[Configuration] -> ShowS
Configuration -> String
(Int -> Configuration -> ShowS)
-> (Configuration -> String)
-> ([Configuration] -> ShowS)
-> Show Configuration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Configuration] -> ShowS
$cshowList :: [Configuration] -> ShowS
show :: Configuration -> String
$cshow :: Configuration -> String
showsPrec :: Int -> Configuration -> ShowS
$cshowsPrec :: Int -> Configuration -> ShowS
Show

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

data UrlArgument = UrlArgLiteral String | UrlArgUrl
  deriving Int -> UrlArgument -> ShowS
[UrlArgument] -> ShowS
UrlArgument -> String
(Int -> UrlArgument -> ShowS)
-> (UrlArgument -> String)
-> ([UrlArgument] -> ShowS)
-> Show UrlArgument
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UrlArgument] -> ShowS
$cshowList :: [UrlArgument] -> ShowS
show :: UrlArgument -> String
$cshow :: UrlArgument -> String
showsPrec :: Int -> UrlArgument -> ShowS
$cshowsPrec :: Int -> 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 -> String
(Int -> PaddingMode -> ShowS)
-> (PaddingMode -> String)
-> ([PaddingMode] -> ShowS)
-> Show PaddingMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PaddingMode] -> ShowS
$cshowList :: [PaddingMode] -> ShowS
show :: PaddingMode -> String
$cshow :: PaddingMode -> String
showsPrec :: Int -> PaddingMode -> ShowS
$cshowsPrec :: Int -> 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 -> String
(Int -> LayoutMode -> ShowS)
-> (LayoutMode -> String)
-> ([LayoutMode] -> ShowS)
-> Show LayoutMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LayoutMode] -> ShowS
$cshowList :: [LayoutMode] -> ShowS
show :: LayoutMode -> String
$cshow :: LayoutMode -> String
showsPrec :: Int -> LayoutMode -> ShowS
$cshowsPrec :: Int -> LayoutMode -> ShowS
Show

data EditMode
  = SingleLineEditor
  | MultiLineEditor
  deriving Int -> EditMode -> ShowS
[EditMode] -> ShowS
EditMode -> String
(Int -> EditMode -> ShowS)
-> (EditMode -> String) -> ([EditMode] -> ShowS) -> Show EditMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EditMode] -> ShowS
$cshowList :: [EditMode] -> ShowS
show :: EditMode -> String
$cshow :: EditMode -> String
showsPrec :: Int -> EditMode -> ShowS
$cshowsPrec :: Int -> 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 -> String
(Int -> ConfigurationFailure -> ShowS)
-> (ConfigurationFailure -> String)
-> ([ConfigurationFailure] -> ShowS)
-> Show ConfigurationFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigurationFailure] -> ShowS
$cshowList :: [ConfigurationFailure] -> ShowS
show :: ConfigurationFailure -> String
$cshow :: ConfigurationFailure -> String
showsPrec :: Int -> ConfigurationFailure -> ShowS
$cshowsPrec :: Int -> ConfigurationFailure -> ShowS
Show

-- | default instance
instance Exception ConfigurationFailure

-- | Configuration information for run-time loaded dynamic
-- library extensions.
data ExtensionConfiguration = ExtensionConfiguration
  { ExtensionConfiguration -> String
_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 -> String
(Int -> ExtensionConfiguration -> ShowS)
-> (ExtensionConfiguration -> String)
-> ([ExtensionConfiguration] -> ShowS)
-> Show ExtensionConfiguration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtensionConfiguration] -> ShowS
$cshowList :: [ExtensionConfiguration] -> ShowS
show :: ExtensionConfiguration -> String
$cshow :: ExtensionConfiguration -> String
showsPrec :: Int -> ExtensionConfiguration -> ShowS
$cshowsPrec :: Int -> 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 String
getConfigPath =
  do String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig String
"glirc"
     return (String
dir String -> ShowS
</> String
"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 String
-> IO (Either ConfigurationFailure (String, Configuration))
loadConfiguration Maybe String
mbPath = IO (String, Configuration)
-> IO (Either ConfigurationFailure (String, Configuration))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (String, Configuration)
 -> IO (Either ConfigurationFailure (String, Configuration)))
-> IO (String, Configuration)
-> IO (Either ConfigurationFailure (String, Configuration))
forall a b. (a -> b) -> a -> b
$
  do String
path <- case Maybe String
mbPath of
               Maybe String
Nothing -> IO String
getConfigPath
               Just String
p  -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
p

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

     let toPath :: Text -> p -> f String
toPath Text
txt p
_ = String -> f String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePathContext -> ShowS
resolveFilePath FilePathContext
ctx (Text -> String
Text.unpack Text
txt))
     Value FilePosition
rawcfg <- (Text -> String -> IO String) -> String -> IO (Value FilePosition)
loadFileWithMacros Text -> String -> IO String
forall (f :: * -> *) p. Applicative f => Text -> p -> f String
toPath String
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 String
fp ParseError
pe -> ConfigurationFailure -> IO (Value FilePosition)
forall e a. Exception e => e -> IO a
throwIO (String -> String -> ConfigurationFailure
ConfigurationParseFailed String
fp (ParseError -> String
forall e. Exception e => e -> String
displayException ParseError
pe))
           LoadFileMacroError (UndeclaredVariable FilePosition
a Text
var) -> FilePosition -> String -> IO (Value FilePosition)
forall a. FilePosition -> String -> IO a
badMacro FilePosition
a (String
"undeclared variable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
var)
           LoadFileMacroError (BadSplice FilePosition
a)              -> FilePosition -> String -> IO (Value FilePosition)
forall a. FilePosition -> String -> IO a
badMacro FilePosition
a String
"bad @splice"
           LoadFileMacroError (BadLoad FilePosition
a)                -> FilePosition -> String -> IO (Value FilePosition)
forall a. FilePosition -> String -> IO a
badMacro FilePosition
a String
"bad @load"
           LoadFileMacroError (UnknownDirective FilePosition
a Text
dir)   -> FilePosition -> String -> IO (Value FilePosition)
forall a. FilePosition -> String -> IO a
badMacro FilePosition
a (String
"unknown directive: @" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
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 String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
mbPath Bool -> Bool -> Bool
&&
               IOError -> Maybe String
ioeGetFileName IOError
e Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
path
            then Value FilePosition -> IO (Value FilePosition)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePosition -> [Section FilePosition] -> Value FilePosition
forall a. a -> [Section a] -> Value a
Sections (String -> Position -> FilePosition
FilePosition String
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 (String -> ConfigurationFailure
ConfigurationReadFailed (IOError -> String
forall e. Exception e => e -> String
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 (String, Configuration)
forall e a. Exception e => e -> IO a
throwIO
               (ConfigurationFailure -> IO (String, Configuration))
-> ConfigurationFailure -> IO (String, Configuration)
forall a b. (a -> b) -> a -> b
$ String -> String -> ConfigurationFailure
ConfigurationMalformed String
path
               (String -> ConfigurationFailure) -> String -> ConfigurationFailure
forall a b. (a -> b) -> a -> b
$ ValueSpecMismatch FilePosition -> String
forall e. Exception e => e -> String
displayException ValueSpecMismatch FilePosition
e
       Right ServerSettings -> Configuration
cfg -> (String, Configuration) -> IO (String, Configuration)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
path, FilePathContext -> Configuration -> Configuration
resolvePaths FilePathContext
ctx (ServerSettings -> Configuration
cfg ServerSettings
defaultServerSettings))

badMacro :: FilePosition -> String -> IO a
badMacro :: FilePosition -> String -> IO a
badMacro (FilePosition String
path Position
posn) String
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
$ String -> String -> ConfigurationFailure
ConfigurationMalformed String
path
          (String -> ConfigurationFailure) -> String -> ConfigurationFailure
forall a b. (a -> b) -> a -> b
$ String
"line "    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Position -> Int
posLine   Position
posn) String -> ShowS
forall a. [a] -> [a] -> [a]
++
            String
" column " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Position -> Int
posColumn Position
posn) String -> ShowS
forall a. [a] -> [a] -> [a]
++
            String
": "       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 String String
-> ShowS -> ServerSettings -> ServerSettings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Maybe String -> Identity (Maybe String))
-> ServerSettings -> Identity ServerSettings
Lens' ServerSettings (Maybe String)
ssTlsClientCert ((Maybe String -> Identity (Maybe String))
 -> ServerSettings -> Identity ServerSettings)
-> ((String -> Identity String)
    -> Maybe String -> Identity (Maybe String))
-> ASetter ServerSettings ServerSettings String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity String)
-> Maybe String -> Identity (Maybe String)
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 String String
-> ShowS -> ServerSettings -> ServerSettings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Maybe String -> Identity (Maybe String))
-> ServerSettings -> Identity ServerSettings
Lens' ServerSettings (Maybe String)
ssTlsClientKey  ((Maybe String -> Identity (Maybe String))
 -> ServerSettings -> Identity ServerSettings)
-> ((String -> Identity String)
    -> Maybe String -> Identity (Maybe String))
-> ASetter ServerSettings ServerSettings String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity String)
-> Maybe String -> Identity (Maybe String)
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 String String
-> ShowS -> ServerSettings -> ServerSettings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Maybe String -> Identity (Maybe String))
-> ServerSettings -> Identity ServerSettings
Lens' ServerSettings (Maybe String)
ssTlsServerCert ((Maybe String -> Identity (Maybe String))
 -> ServerSettings -> Identity ServerSettings)
-> ((String -> Identity String)
    -> Maybe String -> Identity (Maybe String))
-> ASetter ServerSettings ServerSettings String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity String)
-> Maybe String -> Identity (Maybe String)
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 String String
-> 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)
-> ((String -> Identity String)
    -> Maybe SaslMechanism -> Identity (Maybe SaslMechanism))
-> ASetter ServerSettings ServerSettings String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SaslMechanism -> Identity SaslMechanism)
-> Maybe SaslMechanism -> Identity (Maybe SaslMechanism)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((SaslMechanism -> Identity SaslMechanism)
 -> Maybe SaslMechanism -> Identity (Maybe SaslMechanism))
-> ((String -> Identity String)
    -> SaslMechanism -> Identity SaslMechanism)
-> (String -> Identity String)
-> Maybe SaslMechanism
-> Identity (Maybe SaslMechanism)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Text, Text, String) -> Identity (Maybe Text, Text, String))
-> SaslMechanism -> Identity SaslMechanism
Prism' SaslMechanism (Maybe Text, Text, String)
_SaslEcdsa (((Maybe Text, Text, String)
  -> Identity (Maybe Text, Text, String))
 -> SaslMechanism -> Identity SaslMechanism)
-> ((String -> Identity String)
    -> (Maybe Text, Text, String)
    -> Identity (Maybe Text, Text, String))
-> (String -> Identity String)
-> SaslMechanism
-> Identity SaslMechanism
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity String)
-> (Maybe Text, Text, String)
-> Identity (Maybe Text, Text, String)
forall s t a b. Field3 s t a b => Lens s t a b
_3) ShowS
res
                             (ServerSettings -> ServerSettings)
-> (ServerSettings -> ServerSettings)
-> ServerSettings
-> ServerSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter ServerSettings ServerSettings String String
-> ShowS -> ServerSettings -> ServerSettings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Maybe String -> Identity (Maybe String))
-> ServerSettings -> Identity ServerSettings
Lens' ServerSettings (Maybe String)
ssLogDir        ((Maybe String -> Identity (Maybe String))
 -> ServerSettings -> Identity ServerSettings)
-> ((String -> Identity String)
    -> Maybe String -> Identity (Maybe String))
-> ASetter ServerSettings ServerSettings String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity String)
-> Maybe String -> Identity (Maybe String)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ShowS
res
  in ASetter Configuration Configuration String String
-> 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)
-> ((String -> Identity String)
    -> [ExtensionConfiguration] -> Identity [ExtensionConfiguration])
-> ASetter Configuration Configuration String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtensionConfiguration -> Identity ExtensionConfiguration)
-> [ExtensionConfiguration] -> Identity [ExtensionConfiguration]
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((ExtensionConfiguration -> Identity ExtensionConfiguration)
 -> [ExtensionConfiguration] -> Identity [ExtensionConfiguration])
-> ((String -> Identity String)
    -> ExtensionConfiguration -> Identity ExtensionConfiguration)
-> (String -> Identity String)
-> [ExtensionConfiguration]
-> Identity [ExtensionConfiguration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity String)
-> ExtensionConfiguration -> Identity ExtensionConfiguration
Lens' ExtensionConfiguration String
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)
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"
     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 (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 :: ServerSettings
-> HashMap Text ServerSettings
-> Palette
-> Text
-> [Identifier]
-> [Identifier]
-> PaddingMode
-> Recognizer Macro
-> [ExtensionConfiguration]
-> Maybe UrlOpener
-> [Text]
-> Bool
-> Bool
-> Bool
-> KeyMap
-> LayoutMode
-> Bool
-> [Modifier]
-> Map Digraph Text
-> Configuration
Configuration{Bool
[Text]
[Identifier]
[Modifier]
[ExtensionConfiguration]
Maybe UrlOpener
Text
Map Digraph Text
HashMap Text ServerSettings
Recognizer Macro
KeyMap
Palette
ServerSettings
LayoutMode
PaddingMode
_configKeyMap :: KeyMap
_configServers :: HashMap Text ServerSettings
_configDefaults :: ServerSettings
_configDigraphs :: Map Digraph Text
_configShowPing :: Bool
_configLayout :: LayoutMode
_configHideMeta :: Bool
_configBellOnMention :: Bool
_configActivityBar :: Bool
_configIgnores :: [Text]
_configNickPadding :: PaddingMode
_configNeverHighlights :: [Identifier]
_configExtraHighlights :: [Identifier]
_configUrlOpener :: Maybe UrlOpener
_configExtensions :: [ExtensionConfiguration]
_configMacros :: Recognizer Macro
_configJumpModifier :: [Modifier]
_configWindowNames :: Text
_configPalette :: Palette
_configDigraphs :: Map Digraph Text
_configJumpModifier :: [Modifier]
_configShowPing :: Bool
_configLayout :: LayoutMode
_configKeyMap :: KeyMap
_configHideMeta :: Bool
_configBellOnMention :: Bool
_configActivityBar :: Bool
_configIgnores :: [Text]
_configUrlOpener :: Maybe UrlOpener
_configExtensions :: [ExtensionConfiguration]
_configMacros :: Recognizer Macro
_configNickPadding :: PaddingMode
_configNeverHighlights :: [Identifier]
_configExtraHighlights :: [Identifier]
_configWindowNames :: Text
_configPalette :: Palette
_configServers :: HashMap Text ServerSettings
_configDefaults :: ServerSettings
..})

-- | 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 (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 (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 (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 (f :: * -> *) a. Alt f => f a -> f a -> f a
<!>
               Int -> PaddingMode
RightPadding (Int -> PaddingMode)
-> ValueSpec () -> ValueSpec (Int -> PaddingMode)
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 (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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"meta"
                ValueSpec Modifier -> ValueSpec Modifier -> ValueSpec Modifier
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Modifier
MAlt  Modifier -> ValueSpec () -> ValueSpec Modifier
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"alt"
                ValueSpec Modifier -> ValueSpec Modifier -> ValueSpec Modifier
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Modifier
MCtrl Modifier -> ValueSpec () -> ValueSpec Modifier
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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"one-column"
         ValueSpec LayoutMode
-> ValueSpec LayoutMode -> ValueSpec LayoutMode
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> LayoutMode
TwoColumn LayoutMode -> ValueSpec () -> ValueSpec LayoutMode
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 (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec (KeyMap -> KeyMap)
cmdBindingSpec ValueSpec (KeyMap -> KeyMap)
-> ValueSpec (KeyMap -> KeyMap) -> ValueSpec (KeyMap -> KeyMap)
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 String
-> (String -> Either Text ([Modifier], Key))
-> ValueSpec ([Modifier], Key)
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"emacs-key" ValueSpec String
stringSpec
        ((String -> Either Text ([Modifier], Key))
 -> ValueSpec ([Modifier], Key))
-> (String -> Either Text ([Modifier], Key))
-> ValueSpec ([Modifier], Key)
forall a b. (a -> b) -> a -> b
$ \String
key -> case String -> Maybe ([Modifier], Key)
parseKey String
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 :: 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
forall a. (a -> a) -> Endo a
Endo ((Maybe (Palette -> Palette) -> Endo Palette)
-> [Maybe (Palette -> Palette)] -> Endo Palette
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Maybe (Palette -> Palette) -> Endo Palette)
 -> [Maybe (Palette -> Palette)] -> Endo Palette)
-> (((Palette -> Palette) -> Endo Palette)
    -> Maybe (Palette -> Palette) -> Endo Palette)
-> ((Palette -> Palette) -> Endo Palette)
-> [Maybe (Palette -> Palette)]
-> Endo Palette
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Palette -> Palette) -> Endo Palette)
-> Maybe (Palette -> Palette) -> Endo Palette
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)
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

    modeColorsSpec :: Lens' Palette (HashMap Char Attr) -> ValueSpec (Palette -> Palette)
    modeColorsSpec :: Lens' Palette (HashMap Char Attr) -> ValueSpec (Palette -> Palette)
modeColorsSpec Lens' Palette (HashMap Char Attr)
l
      = (HashMap Char Attr -> Palette -> Palette)
-> ValueSpec (HashMap Char Attr) -> ValueSpec (Palette -> Palette)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ASetter Palette Palette (HashMap Char Attr) (HashMap Char Attr)
-> HashMap Char Attr -> Palette -> Palette
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Palette Palette (HashMap Char Attr) (HashMap Char Attr)
Lens' Palette (HashMap Char Attr)
l)
      (ValueSpec (HashMap Char Attr) -> ValueSpec (Palette -> Palette))
-> ValueSpec (HashMap Char Attr) -> ValueSpec (Palette -> Palette)
forall a b. (a -> b) -> a -> b
$ Text
-> ValueSpec [(Text, Attr)]
-> ([(Text, Attr)] -> Either Text (HashMap Char Attr))
-> ValueSpec (HashMap Char Attr)
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"modes" (ValueSpec Attr -> ValueSpec [(Text, Attr)]
forall a. ValueSpec a -> ValueSpec [(Text, a)]
assocSpec ValueSpec Attr
attrSpec)
      (([(Text, Attr)] -> Either Text (HashMap Char Attr))
 -> ValueSpec (HashMap Char Attr))
-> ([(Text, Attr)] -> Either Text (HashMap Char Attr))
-> ValueSpec (HashMap Char Attr)
forall a b. (a -> b) -> a -> b
$ ([(Char, Attr)] -> HashMap Char Attr)
-> Either Text [(Char, Attr)] -> Either Text (HashMap Char Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Char, Attr)] -> HashMap Char Attr
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
      (Either Text [(Char, Attr)] -> Either Text (HashMap Char Attr))
-> ([(Text, Attr)] -> Either Text [(Char, Attr)])
-> [(Text, Attr)]
-> Either Text (HashMap Char Attr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Attr) -> Either Text (Char, Attr))
-> [(Text, Attr)] -> Either Text [(Char, Attr)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Text
mode, Attr
attr) ->
          case Text -> String
Text.unpack Text
mode of
            [Char
m] -> (Char, Attr) -> Either Text (Char, Attr)
forall a b. b -> Either a b
Right (Char
m, Attr
attr)
            String
_   -> Text -> Either Text (Char, Attr)
forall a b. a -> Either a b
Left Text
"expected single letter")

    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
"nick-colors" ValueSpec (Palette -> Palette)
nickColorsSpec
             Text
"Colors used to highlight nicknames"

           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
"cmodes" (Lens' Palette (HashMap Char Attr) -> ValueSpec (Palette -> Palette)
modeColorsSpec Lens' Palette (HashMap Char Attr)
palCModes)
             Text
"Colors used to highlight channel modes"

           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
"umodes" (Lens' Palette (HashMap Char Attr) -> ValueSpec (Palette -> Palette)
modeColorsSpec Lens' Palette (HashMap Char Attr)
palUModes)
             Text
"Colors used to highlight user modes"

           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
"snomask" (Lens' Palette (HashMap Char Attr) -> ValueSpec (Palette -> Palette)
modeColorsSpec Lens' Palette (HashMap Char Attr)
palSnomask)
             Text
"Colors used to highlight server notice mask"

           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 (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 String
_extensionPath <- ValueSpec String
stringSpec
     pure ExtensionConfiguration :: String -> [RTLDFlags] -> [Text] -> ExtensionConfiguration
ExtensionConfiguration
       { _extensionRtldFlags :: [RTLDFlags]
_extensionRtldFlags = [RTLDFlags]
defaultRtldFlags
       , _extensionArgs :: [Text]
_extensionArgs      = []
       , String
_extensionPath :: String
_extensionPath :: String
.. }

-- | 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 String
_extensionPath      <- Text -> ValueSpec String -> Text -> SectionsSpec String
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"path"       ValueSpec String
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 :: String -> [RTLDFlags] -> [Text] -> ExtensionConfiguration
ExtensionConfiguration {String
[Text]
[RTLDFlags]
_extensionArgs :: [Text]
_extensionRtldFlags :: [RTLDFlags]
_extensionPath :: String
_extensionArgs :: [Text]
_extensionRtldFlags :: [RTLDFlags]
_extensionPath :: String
..}

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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"local"
           ValueSpec RTLDFlags -> ValueSpec RTLDFlags -> ValueSpec RTLDFlags
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> RTLDFlags
RTLD_GLOBAL RTLDFlags -> ValueSpec () -> ValueSpec RTLDFlags
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"global"
           ValueSpec RTLDFlags -> ValueSpec RTLDFlags -> ValueSpec RTLDFlags
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> RTLDFlags
RTLD_NOW    RTLDFlags -> ValueSpec () -> ValueSpec RTLDFlags
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"now"
           ValueSpec RTLDFlags -> ValueSpec RTLDFlags -> ValueSpec RTLDFlags
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> RTLDFlags
RTLD_LAZY   RTLDFlags -> ValueSpec () -> ValueSpec RTLDFlags
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 (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec UrlOpener
complexCase
  where
    simpleCase :: ValueSpec UrlOpener
simpleCase =
      do String
path <- ValueSpec String
stringSpec
         pure (String -> [UrlArgument] -> UrlOpener
UrlOpener String
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 String
path <- Text -> ValueSpec String -> Text -> SectionsSpec String
forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"path" ValueSpec String
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 (String -> [UrlArgument] -> UrlOpener
UrlOpener String
path [UrlArgument]
args)

    argSpec :: ValueSpec UrlArgument
argSpec = UrlArgument
UrlArgUrl     UrlArgument -> ValueSpec () -> ValueSpec UrlArgument
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Text -> ValueSpec ()
atomSpec Text
"url"
          ValueSpec UrlArgument
-> ValueSpec UrlArgument -> ValueSpec UrlArgument
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> String -> UrlArgument
UrlArgLiteral (String -> UrlArgument)
-> ValueSpec String -> ValueSpec UrlArgument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec String
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 String
-> (String -> Either Text (Char, Char))
-> ValueSpec (Char, Char)
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"two" ValueSpec String
stringSpec ((String -> Either Text (Char, Char)) -> ValueSpec (Char, Char))
-> (String -> 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)
        String
_     -> 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 String
-> (String -> 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 String
Lens' ServerSettings String
ssHostName String -> 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 (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 -> String
fpBase, FilePathContext -> String
fpHome :: FilePath }

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

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