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

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

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

data EditMode
  = SingleLineEditor
  | MultiLineEditor
  deriving Int -> EditMode -> ShowS
[EditMode] -> ShowS
EditMode -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [EditMode] -> ShowS
$cshowList :: [EditMode] -> ShowS
show :: EditMode -> FilePath
$cshow :: EditMode -> FilePath
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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ConfigurationFailure] -> ShowS
$cshowList :: [ConfigurationFailure] -> ShowS
show :: ConfigurationFailure -> FilePath
$cshow :: ConfigurationFailure -> FilePath
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 -> 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
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ExtensionConfiguration] -> ShowS
$cshowList :: [ExtensionConfiguration] -> ShowS
show :: ExtensionConfiguration -> FilePath
$cshow :: ExtensionConfiguration -> FilePath
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 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 = forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$
  do FilePath
path <- case Maybe FilePath
mbPath of
               Maybe FilePath
Nothing -> IO FilePath
getConfigPath
               Just FilePath
p  -> 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
_ = 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 forall {f :: * -> *} {p}. Applicative f => Text -> p -> f FilePath
toPath FilePath
path
        forall a. IO a -> [Handler a] -> IO a
`catches`
        [forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \LoadFileError
e -> case LoadFileError
e of
           LoadFileParseError FilePath
fp ParseError
pe -> forall e a. Exception e => e -> IO a
throwIO (FilePath -> FilePath -> ConfigurationFailure
ConfigurationParseFailed FilePath
fp (forall e. Exception e => e -> FilePath
displayException ParseError
pe))
           LoadFileMacroError (UndeclaredVariable FilePosition
a Text
var) -> forall a. FilePosition -> FilePath -> IO a
badMacro FilePosition
a (FilePath
"undeclared variable: " forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack Text
var)
           LoadFileMacroError (BadSplice FilePosition
a)              -> forall a. FilePosition -> FilePath -> IO a
badMacro FilePosition
a FilePath
"bad @splice"
           LoadFileMacroError (BadLoad FilePosition
a)                -> forall a. FilePosition -> FilePath -> IO a
badMacro FilePosition
a FilePath
"bad @load"
           LoadFileMacroError (UnknownDirective FilePosition
a Text
dir)   -> forall a. FilePosition -> FilePath -> IO a
badMacro FilePosition
a (FilePath
"unknown directive: @" forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack Text
dir)
        ,forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \IOError
e ->
            if IOError -> Bool
isDoesNotExistError IOError
e Bool -> Bool -> Bool
&&
               forall a. Maybe a -> Bool
isNothing Maybe FilePath
mbPath Bool -> Bool -> Bool
&&
               IOError -> Maybe FilePath
ioeGetFileName IOError
e forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just FilePath
path
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall e a. Exception e => e -> IO a
throwIO (FilePath -> ConfigurationFailure
ConfigurationReadFailed (forall e. Exception e => e -> FilePath
displayException IOError
e))
        ]

     case forall a p.
ValueSpec a -> Value p -> Either (ValueSpecMismatch p) a
loadValue ValueSpec (ServerSettings -> Configuration)
configurationSpec Value FilePosition
rawcfg of
       Left ValueSpecMismatch FilePosition
e -> forall e a. Exception e => e -> IO a
throwIO
               forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> ConfigurationFailure
ConfigurationMalformed FilePath
path
               forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> FilePath
displayException ValueSpecMismatch FilePosition
e
       Right ServerSettings -> Configuration
cfg -> 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 =
  forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> ConfigurationFailure
ConfigurationMalformed FilePath
path
          forall a b. (a -> b) -> a -> b
$ FilePath
"line "    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (Position -> Int
posLine   Position
posn) forall a. [a] -> [a] -> [a]
++
            FilePath
" column " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (Position -> Int
posColumn Position
posn) forall a. [a] -> [a] -> [a]
++
            FilePath
": "       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 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' ServerSettings (Maybe FilePath)
ssTlsClientCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ShowS
res
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' ServerSettings (Maybe FilePath)
ssTlsClientKey  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ShowS
res
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' ServerSettings (Maybe FilePath)
ssTlsServerCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ShowS
res
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' SaslMechanism (Maybe Text, Text, FilePath)
_SaslEcdsa forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
_3) ShowS
res
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' ServerSettings (Maybe FilePath)
ssLogDir        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ShowS
res
  in forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' Configuration [ExtensionConfiguration]
configExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionConfiguration FilePath
extensionPath) ShowS
res
   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' Configuration (HashMap Text ServerSettings)
configServers    forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"config-file" 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 = forall a. a -> Maybe a -> a
fromMaybe b
def forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
name ValueSpec b
spec Text
info

     (Maybe Text, ServerSettings -> ServerSettings)
ssDefUpdate            <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' (forall a. Maybe a
Nothing,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              <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [] Text
"servers" (forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec (Maybe Text, ServerSettings -> ServerSettings)
serverSpec)
                               Text
"Configuration parameters for IRC servers"
     Palette
_configPalette         <- 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     <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' Text
defaultWindowNames Text
"window-names" forall a. HasSpec a => ValueSpec a
anySpec
                               Text
"Window names to use for quick jumping with jump-modifier key"
     [Modifier]
_configJumpModifier    <- 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          <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' forall a. Monoid a => a
mempty Text
"macros" ValueSpec (Recognizer Macro)
macroMapSpec
                               Text
"Programmable macro commands"
     [ExtensionConfiguration]
_configExtensions      <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [] Text
"extensions" (forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec ExtensionConfiguration
extensionSpec)
                               Text
"extension libraries to load at startup"
     Maybe UrlOpener
_configUrlOpener       <- 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 <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' forall a. Monoid a => a
mempty Text
"extra-highlights" (forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec Identifier
identifierSpec)
                               Text
"Extra words to highlight in chat messages"
     [Identifier]
_configNeverHighlights <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' forall a. Monoid a => a
mempty Text
"never-highlights" (forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec Identifier
identifierSpec)
                               Text
"Words to avoid highlighting in chat messages"
     PaddingMode
_configNickPadding     <- 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         <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [] Text
"ignores" forall a. HasSpec a => ValueSpec a
anySpec
                               Text
"Set of nicknames to ignore on startup"
     Bool
_configActivityBar     <- 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   <- 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        <- 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               <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' [] Text
"key-bindings" (forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec (KeyMap -> KeyMap)
keyBindingSpec)
                               Text
"Extra key bindings"
     LayoutMode
_configLayout          <- 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        <- 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        <- forall {b}. b -> Text -> ValueSpec b -> Text -> SectionsSpec b
sec' forall a. Monoid a => a
mempty Text
"extra-digraphs" (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec (Digraph, Text)
digraphSpec)
                               Text
"Extra digraphs"
     NotifyWith
_configNotifications   <- 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 = 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   = 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
_configKeyMap :: KeyMap
_configServers :: HashMap Text ServerSettings
_configDefaults :: ServerSettings
_configNotifications :: NotifyWith
_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
_configNotifications :: NotifyWith
_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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Ord a, Num a) => ValueSpec a
nonnegativeSpec 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 = forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"nick-padding" (SectionsSpec (Int -> PaddingMode)
sideSec 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  forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"left" forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!>
               Int -> PaddingMode
RightPadding forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"right"

    sideSec :: SectionsSpec (Int -> PaddingMode)
sideSec = forall a. a -> Maybe a -> a
fromMaybe Int -> PaddingMode
defaultPaddingSide
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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  = forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"width" 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 = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ValueSpec a -> ValueSpec (NonEmpty a)
oneOrNonemptySpec ValueSpec Modifier
modifier1Spec
  where
    modifier1Spec :: ValueSpec Modifier
modifier1Spec = forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"modifier"
                  forall a b. (a -> b) -> a -> b
$ Modifier
MMeta forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"meta"
                forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Modifier
MAlt  forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"alt"
                forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Modifier
MCtrl 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 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"one-column"
         forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> LayoutMode
TwoColumn 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 forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec (KeyMap -> KeyMap)
cmdBindingSpec 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 = forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"action-binding" forall a b. (a -> b) -> a -> b
$
  do ~([Modifier]
m,Key
k) <- 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      <- 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 = forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"command-binding" forall a b. (a -> b) -> a -> b
$
  do ~([Modifier]
m,Key
k) <- 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    <- 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 = forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"remove-binding" forall a b. (a -> b) -> a -> b
$
  do ~([Modifier]
m,Key
k) <- 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 = forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"emacs-key" ValueSpec FilePath
stringSpec
        forall a b. (a -> b) -> a -> b
$ \FilePath
key -> case FilePath -> Maybe ([Modifier], Key)
parseKey FilePath
key of
                    Maybe ([Modifier], Key)
Nothing -> forall a b. a -> Either a b
Left Text
"unknown key"
                    Just ([Modifier], Key)
x  -> 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 = forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"non-negative" forall a. Num a => ValueSpec a
numSpec
                forall a b. (a -> b) -> a -> b
$ \a
x -> if a
x forall a. Ord a => a -> a -> Bool
< a
0 then forall a b. a -> Either a b
Left Text
"negative number"
                                 else forall a b. b -> Either a b
Right a
x


paletteSpec :: ValueSpec Palette
paletteSpec :: ValueSpec Palette
paletteSpec = forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"palette" forall a b. (a -> b) -> a -> b
$
  (forall (f :: * -> *) s t.
(Functor f, Rewrapping s t) =>
(Unwrapped s -> s)
-> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s)
ala forall a. (a -> a) -> Endo a
Endo (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? Palette
defaultPalette) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Palette (Vector Attr)
palNicks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
Vector.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList
                 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ValueSpec a -> ValueSpec (NonEmpty a)
nonemptySpec ValueSpec Attr
attrSpec

    idOverridesSpec :: ValueSpec (Palette -> Palette)
idOverridesSpec = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Palette (HashMap Identifier Attr)
palIdOverride forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec [(Identifier, Attr)]
idOverrideSpec
    idOverrideSpec :: ValueSpec [(Identifier, Attr)]
idOverrideSpec =
      forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"ids-to-attr" forall a b. (a -> b) -> a -> b
$
      do [FilePath]
ids <- forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"ids" (forall a. ValueSpec a -> ValueSpec [a]
oneOrList ValueSpec FilePath
stringSpec) Text
"One or more identifiers that this override applies to."
         Attr
attr <- forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"color" ValueSpec Attr
attrSpec Text
"The style to use."
         pure [(Text -> Identifier
mkId 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 = 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)."
           forall a. a -> [a] -> [a]
: 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)."
           forall a. a -> [a] -> [a]
: [ forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
lbl (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens Palette Palette Attr Attr
l 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 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 =
  forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"extension" forall a b. (a -> b) -> a -> b
$
  do FilePath
_extensionPath      <- forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"path"       ValueSpec FilePath
stringSpec
                            Text
"Path to shared object"
     [RTLDFlags]
_extensionRtldFlags <- forall a. a -> Maybe a -> a
fromMaybe [RTLDFlags]
defaultRtldFlags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"rtld-flags" (forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec RTLDFlags
rtldFlagSpec)
                            Text
"Runtime dynamic linker flags"
     [Text]
_extensionArgs      <- forall a. a -> Maybe a -> a
fromMaybe [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasSpec a => Text -> Text -> SectionsSpec (Maybe a)
optSection Text
"args"
                            Text
"Extension-specific configuration arguments"
     pure ExtensionConfiguration {FilePath
[Text]
[RTLDFlags]
_extensionArgs :: [Text]
_extensionRtldFlags :: [RTLDFlags]
_extensionPath :: FilePath
_extensionArgs :: [Text]
_extensionRtldFlags :: [RTLDFlags]
_extensionPath :: FilePath
..}

rtldFlagSpec :: ValueSpec RTLDFlags
rtldFlagSpec :: ValueSpec RTLDFlags
rtldFlagSpec = forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"rtld-flag"
             forall a b. (a -> b) -> a -> b
$ RTLDFlags
RTLD_LOCAL  forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"local"
           forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> RTLDFlags
RTLD_GLOBAL forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"global"
           forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> RTLDFlags
RTLD_NOW    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"now"
           forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> RTLDFlags
RTLD_LAZY   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 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 = forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"url-opener" forall a b. (a -> b) -> a -> b
$
      do FilePath
path <- forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"path" ValueSpec FilePath
stringSpec Text
"Executable"
         [UrlArgument]
args <- forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"args" (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     forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Text -> ValueSpec ()
atomSpec Text
"url"
          forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> FilePath -> UrlArgument
UrlArgLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec FilePath
stringSpec

digraphSpec :: ValueSpec (Digraph, Text)
digraphSpec :: ValueSpec (Digraph, Text)
digraphSpec =
  forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"digraph" forall a b. (a -> b) -> a -> b
$
   do ~(Char
x,Char
y) <- forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"input" ValueSpec (Char, Char)
twoChars Text
"digraph key"
      Text
val    <- 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 = forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"two" ValueSpec FilePath
stringSpec forall a b. (a -> b) -> a -> b
$ \case
        [Char
x,Char
y] -> forall a b. b -> Either a b
Right (Char
x,Char
y)
        FilePath
_     -> 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 forall k v. HashMap k v
HashMap.empty ServerSettings
def forall a. Maybe a
Nothing
  where
    serverSettingName :: ServerSettings -> Text
serverSettingName ServerSettings
ss =
      forall a. a -> Maybe a -> a
fromMaybe (forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views Lens' ServerSettings FilePath
ssHostName FilePath -> Text
Text.pack ServerSettings
ss)
                (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe Text)
ssName ServerSettings
ss)

    raw :: HashMap (Maybe Text) [ServerSettings -> ServerSettings]
raw = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith 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 = 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 = 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 (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'
          | 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             = 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) 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 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 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe NetworkPalette
defaultNetworkPalette Maybe NetworkPalette
palNet
  where
    palNet :: Maybe NetworkPalette
palNet = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings NetworkPalette
ssPalette forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' Configuration (HashMap Text ServerSettings)
configServers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
net) Configuration
cfg
    palDefault :: NetworkPalette
palDefault = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' Configuration ServerSettings
configDefaultsforall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ServerSettings NetworkPalette
ssPalette) Configuration
cfg