{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
module Client.Configuration
(
Configuration(..)
, ConfigurationFailure(..)
, LayoutMode(..)
, EditMode(..)
, PaddingMode(..)
, ExtensionConfiguration(..)
, configDefaults
, configServers
, configPalette
, configWindowNames
, configNickPadding
, configMacros
, configExtensions
, configExtraHighlights
, configNeverHighlights
, configUrlOpener
, configIgnores
, configActivityBar
, configBellOnMention
, configHideMeta
, configKeyMap
, configLayout
, configShowPing
, configJumpModifier
, configDigraphs
, configNotifications
, configNetworkPalette
, extensionPath
, extensionRtldFlags
, extensionArgs
, loadConfiguration
, getConfigPath
, configurationSpec
, FilePathContext
, newFilePathContext
, resolveFilePath
, 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(..))
data Configuration = Configuration
{ Configuration -> ServerSettings
_configDefaults :: ServerSettings
, Configuration -> HashMap Text ServerSettings
_configServers :: (HashMap Text ServerSettings)
, Configuration -> Palette
_configPalette :: Palette
, Configuration -> Text
_configWindowNames :: Text
, :: [Identifier]
, Configuration -> [Identifier]
_configNeverHighlights :: [Identifier]
, Configuration -> PaddingMode
_configNickPadding :: PaddingMode
, Configuration -> Recognizer Macro
_configMacros :: Recognizer Macro
, Configuration -> [ExtensionConfiguration]
_configExtensions :: [ExtensionConfiguration]
, Configuration -> Maybe UrlOpener
_configUrlOpener :: Maybe UrlOpener
, Configuration -> [Text]
_configIgnores :: [Text]
, Configuration -> Bool
_configActivityBar :: Bool
, Configuration -> Bool
_configBellOnMention :: Bool
, Configuration -> Bool
_configHideMeta :: Bool
, Configuration -> KeyMap
_configKeyMap :: KeyMap
, Configuration -> LayoutMode
_configLayout :: LayoutMode
, Configuration -> Bool
_configShowPing :: Bool
, Configuration -> [Modifier]
_configJumpModifier :: [Modifier]
, Configuration -> Map Digraph Text
_configDigraphs :: Map Digraph Text
, 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
data PaddingMode
= LeftPadding !Int
| RightPadding !Int
| NoPadding
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
= OneColumn
| 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
data ConfigurationFailure
= ConfigurationReadFailed String
| ConfigurationParseFailed FilePath String
| 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
instance Exception ConfigurationFailure
data ExtensionConfiguration = ExtensionConfiguration
{ ExtensionConfiguration -> FilePath
_extensionPath :: FilePath
, ExtensionConfiguration -> [RTLDFlags]
_extensionRtldFlags :: [RTLDFlags]
, ExtensionConfiguration -> [Text]
_extensionArgs :: [Text]
}
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 ''ExtensionConfiguration
defaultWindowNames :: Text
defaultWindowNames :: Text
defaultWindowNames = Text
"1234567890qwertyuiop!@#$%^&*()QWERTYUIOP"
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")
loadConfiguration ::
Maybe FilePath ->
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
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
..})
defaultPaddingSide :: Int -> PaddingMode
defaultPaddingSide :: Int -> PaddingMode
defaultPaddingSide = Int -> PaddingMode
RightPadding
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
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"
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"
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"
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
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)
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
defaultRtldFlags :: [RTLDFlags]
defaultRtldFlags :: [RTLDFlags]
defaultRtldFlags = [RTLDFlags
RTLD_LOCAL, RTLDFlags
RTLD_NOW]
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
.. }
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 ->
[(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 ->
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
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