glirc 2.20.5 → 2.20.6

raw patch · 11 files changed

+224/−434 lines, 11 filesdep +config-schemadep +semigroupoidsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: config-schema, semigroupoids

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• exec/Main.hs +1/−1
• glirc.cabal +6/−5
• src/Client/Commands.hs +1/−1
• src/Client/Configuration.hs +151/−143
• src/Client/Configuration/Colors.hs +48/−70
• src/Client/Image/Message.hs +1/−1
• src/Client/Network/Async.hs +0/−1
• src/Client/Network/Connect.hs +0/−2
• src/Client/Options.hs +11/−2
• src/Config/FromConfig.hs +0/−208

@@ -1,5 +1,10 @@ # Revision history for glirc2 +## 2.20.6++* Switch to new `config-schema` package for configuration file loading.+* Add `--config-format` flag to executable to show configuration file format.+ ## 2.20.5  * Add line indicating message since previous time window was focused.

@@ -57,7 +57,7 @@        Left (ConfigurationParseFailed e) ->          report "Failed to parse configuration:" e        Left (ConfigurationMalformed e) ->-         report "Configuration malformed: " e+         report "Configuration malformed (try --config-format): " e   where     report problem msg =       do hPutStrLn stderr problem

@@ -1,5 +1,5 @@ name:                glirc-version:             2.20.5+version:             2.20.6 synopsis:            Console IRC client description:         Console IRC client                      .@@ -23,9 +23,9 @@ tested-with:         GHC==8.0.2  custom-setup-  setup-depends: base  >=4.9  && <4.11,-                 filepath >1.4 && <1.5,-                 Cabal >=1.24 && <3+  setup-depends: base     >=4.9  && <4.11,+                 filepath >=1.4  && <1.5,+                 Cabal    >=1.24 && <3  source-repository head   type: git@@ -111,7 +111,6 @@                        Client.View.UrlSelection                        Client.View.UserList                        Client.View.Windows-                       Config.FromConfig    other-modules:       LensUtils                        StrictUnit@@ -125,6 +124,7 @@                        bytestring           >=0.10.8 && <0.11,                        base64-bytestring    >=1.0.0.1 && <1.1,                        config-value         >=0.5    && <0.6,+                       config-schema        >=0.1    && <0.2,                        containers           >=0.5.7  && <0.6,                        directory            >=1.2.6  && <1.4,                        filepath             >=1.4.1  && <1.5,@@ -137,6 +137,7 @@                        network              >=2.6.2  && <2.7,                        process              >=1.4.2  && <1.7,                        regex-tdfa           >=1.2    && <1.3,+                       semigroupoids        >=5.2    && <5.3,                        socks                >=0.5.5  && <0.6,                        split                >=0.2    && <0.3,                        stm                  >=2.4    && <2.5,

@@ -1048,7 +1048,7 @@ -- | Tab completion for @/splits-@. This completes only from the list of active -- entries in the splits list. tabActiveSplits :: Bool -> ClientCommand String-tabActiveSplits isReversed st rest =+tabActiveSplits isReversed st _ =   simpleTabCompletion plainWordCompleteMode [] completions isReversed st   where     completions = renderFocus <$> view clientExtraFocus st

@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE ApplicativeDo     #-}  {-| Module      : Client.Configuration@@ -40,6 +41,9 @@    -- * Resolving paths   , resolveConfigurationPath++  -- * Specification+  , configurationSpec   ) where  import           Client.Commands.Interpolation@@ -49,11 +53,12 @@ import           Client.Configuration.ServerSettings import           Client.Image.Palette import           Config-import           Config.FromConfig+import           Config.Schema+import           Control.Applicative import           Control.Exception import           Control.Lens                        hiding (List)-import           Control.Monad-import           Data.Foldable                       (for_)+import           Data.Foldable                       (find, foldl')+import           Data.Functor.Alt                    ((<!>)) import           Data.HashMap.Strict                 (HashMap) import qualified Data.HashMap.Strict                 as HashMap import           Data.HashSet                        (HashSet)@@ -61,6 +66,7 @@ import           Data.List.NonEmpty                  (NonEmpty) import qualified Data.List.NonEmpty                  as NonEmpty import           Data.Maybe+import           Data.Monoid                         ((<>)) import           Data.Text                           (Text) import qualified Data.Text                           as Text import qualified Data.Text.IO                        as Text@@ -179,158 +185,170 @@          Left parseError -> throwIO (ConfigurationParseFailed parseError)          Right rawcfg -> return rawcfg -     case runConfigParser (parseConfiguration mbPath def rawcfg) of-       Left loadError -> throwIO (ConfigurationMalformed (Text.unpack loadError))-       Right cfg -> return cfg+     case loadValue configurationSpec rawcfg of+       Left es -> throwIO+                $ ConfigurationMalformed+                $ Text.unpack+                $ Text.unlines $ map explainLoadError es+       Right cfg -> return (cfg mbPath def)  -parseConfiguration ::-  Maybe FilePath {- ^ optionally specified path to config -} ->-  ServerSettings {- ^ prepopulated default server settings -} ->-  Value ->-  ConfigParser Configuration-parseConfiguration _configConfigPath def = parseSections $+explainLoadError :: LoadError -> Text+explainLoadError (LoadError path problem) =+  Text.intercalate "." path <> ": " <>+  case problem of+    UnusedSections xs -> "Unknown sections: " <> Text.intercalate ", " xs+    MissingSection s  -> "Missing required section: " <> s+    SpecMismatch   s  -> "Expected " <> s -  do _configDefaults <- fromMaybe def-                    <$> sectionOptWith (parseServerSettings def) "defaults" -     _configServers  <- fromMaybe HashMap.empty-                    <$> sectionOptWith (parseServers _configDefaults) "servers"+configurationSpec :: ValueSpecs (Maybe FilePath -> ServerSettings -> Configuration)+configurationSpec = sectionsSpec "" $ +  do ssDefUpdate <- fromMaybe id <$> optSection' "defaults" "" serverSpec+     ssUpdates   <- fromMaybe [] <$> optSection' "servers" "" (listSpec serverSpec)+      _configPalette <- fromMaybe defaultPalette-                    <$> sectionOptWith parsePalette "palette"+                    <$> optSection' "palette" "" paletteSpec       _configWindowNames <- fromMaybe defaultWindowNames-                    <$> sectionOpt "window-names"+                    <$> optSection "window-names" ""       _configMacros <- fromMaybe mempty-                    <$> sectionOptWith parseMacroMap "macros"+                    <$> optSection' "macros" "" macroMapSpec -     _configExtensions <- fromMaybe []-                    <$> sectionOptWith (parseList parseString) "extensions"+     _configExtensions <- fromMaybe [] <$> optSection' "extensions" "" (listSpec stringSpec) -     _configUrlOpener <- sectionOptWith parseString "url-opener"+     _configUrlOpener <- optSection' "url-opener" "" stringSpec -     _configExtraHighlights <- maybe HashSet.empty HashSet.fromList-                    <$> sectionOptWith (parseList parseIdentifier) "extra-highlights"+     _configExtraHighlights <- maybe HashSet.empty (HashSet.fromList . map mkId)+                    <$> optSection "extra-highlights" "" -     _configNickPadding <- sectionOpt "nick-padding"+     _configNickPadding <- optSection' "nick-padding" "" nonnegativeSpec -     _configIndentWrapped <- sectionOpt "indent-wrapped-lines"+     _configIndentWrapped <- optSection' "indent-wrapped-lines" "" nonnegativeSpec -     _configIgnores <- maybe HashSet.empty HashSet.fromList-                    <$> sectionOptWith (parseList parseIdentifier) "ignores"+     _configIgnores <- maybe HashSet.empty (HashSet.fromList . map mkId)+                    <$> optSection "ignores" "" -     _configActivityBar <- fromMaybe False <$> sectionOpt  "activity-bar"+     _configActivityBar <- fromMaybe False+                    <$> optSection' "activity-bar" "" yesOrNoSpec -     _configBellOnMention <- fromMaybe False <$> sectionOpt  "bell-on-mention"+     _configBellOnMention <- fromMaybe False <$> optSection' "bell-on-mention" "" yesOrNoSpec -     for_ _configNickPadding (\padding ->-       when (padding < 0)-            (liftConfigParser $-               failure "nick-padding has to be a non negative number"))+     return (\_configConfigPath def ->+             let _configDefaults = ssDefUpdate def+                 _configServers  = buildServerMap _configDefaults ssUpdates+             in Configuration{..}) -     for_ _configIndentWrapped (\indent ->-       when (indent < 0)-            (liftConfigParser $-               failure "indent-wrapped-lines has to be a non negative number")) -     return Configuration{..}+nonnegativeSpec :: (Ord a, Num a) => ValueSpecs a+nonnegativeSpec = customSpec "non-negative" numSpec $ \x -> find (0 <=) [x] -parsePalette :: Value -> ConfigParser Palette-parsePalette = parseSectionsWith paletteHelper defaultPalette -paletteHelper :: Palette -> Text -> Value -> ConfigParser Palette-paletteHelper p k v =-  case k of-    "nick-colors" -> do xs <- Vector.fromList <$> parseList parseAttr v-                        when (null xs) (failure "Empty palette")-                        return $! set palNicks xs p-    _ | Just (Lens l) <- lookup k paletteMap ->-          do !attr <- parseAttr v-             return $! set l attr p-    _ -> failure "Unknown palette entry"+paletteSpec :: ValueSpecs Palette+paletteSpec = sectionsSpec "palette" $+  do updates <- catMaybes <$> sequenceA+       [ fmap (set l) <$> optSection' lbl "" attrSpec | (lbl, Lens l) <- paletteMap ]+     nickColors <- optSection' "nick-colors" "" (nonemptyList attrSpec)+     return (let pal1 = foldl' (\acc f -> f acc) defaultPalette updates+             in case nickColors of+                  Nothing -> pal1+                  Just xs -> set palNicks (Vector.fromList (NonEmpty.toList xs)) pal1) -parseServers :: ServerSettings -> Value -> ConfigParser (HashMap Text ServerSettings)-parseServers def v =-  do sss <- parseList (parseServerSettings def) v-     return (HashMap.fromList [(serverSettingName ss, ss) | ss <- sss])+nonemptyList :: ValueSpecs a -> ValueSpecs (NonEmpty a)+nonemptyList s = customSpec "non-empty" (listSpec s) NonEmpty.nonEmpty+++buildServerMap :: ServerSettings -> [ServerSettings -> ServerSettings] -> HashMap Text ServerSettings+buildServerMap def ups =+  HashMap.fromList [ (serverSettingName ss, ss) | up <- ups, let ss = up def ]   where     serverSettingName ss =       fromMaybe (views ssHostName Text.pack ss)                 (view ssName ss) -parseServerSettings :: ServerSettings -> Value -> ConfigParser ServerSettings-parseServerSettings = parseSectionsWith parseServerSetting--parseServerSetting :: ServerSettings -> Text -> Value -> ConfigParser ServerSettings-parseServerSetting ss k v =-  case k of-    "nick"                -> setFieldWith   ssNicks parseNicks-    "username"            -> setField       ssUser-    "realname"            -> setField       ssReal-    "userinfo"            -> setField       ssUserInfo-    "password"            -> setFieldMb     ssPassword-    "sasl-username"       -> setFieldMb     ssSaslUsername-    "sasl-password"       -> setFieldMb     ssSaslPassword-    "sasl-ecdsa-key"      -> setFieldWithMb ssSaslEcdsaFile parseString-    "hostname"            -> setFieldWith   ssHostName      parseString-    "port"                -> setFieldWithMb ssPort          parseNum-    "tls"                 -> setFieldWith   ssTls           parseUseTls-    "tls-client-cert"     -> setFieldWithMb ssTlsClientCert parseString-    "tls-client-key"      -> setFieldWithMb ssTlsClientKey  parseString-    "tls-server-cert"     -> setFieldWithMb ssTlsServerCert parseString-    "tls-ciphers"         -> setFieldWith   ssTlsCiphers    parseString-    "connect-cmds"        -> setFieldWith   ssConnectCmds   (parseList parseMacroCommand)-    "socks-host"          -> setFieldWithMb ssSocksHost     parseString-    "socks-port"          -> setFieldWith   ssSocksPort     parseNum-    "chanserv-channels"   -> setFieldWith   ssChanservChannels (parseList parseIdentifier)-    "flood-penalty"       -> setField       ssFloodPenalty-    "flood-threshold"     -> setField       ssFloodThreshold-    "message-hooks"       -> setField       ssMessageHooks-    "name"                -> setFieldMb     ssName-    "reconnect-attempts"  -> setField       ssReconnectAttempts-    "autoconnect"         -> setField       ssAutoconnect-    "nick-completion"     -> setFieldWith   ssNickCompletion parseNickCompletion-    "log-dir"             -> setFieldWithMb ssLogDir parseString-    _                     -> failure "Unknown setting"+serverSpec :: ValueSpecs (ServerSettings -> ServerSettings)+serverSpec = sectionsSpec "server-settings" $+  do updates <- catMaybes <$> sequenceA settings+     return (foldr (.) id updates)   where-    setField   l = setFieldWith   l parseConfig-    setFieldMb l = setFieldWithMb l parseConfig+    req l s = set l <$> s -    setFieldWith l p =-      do x <- p v-         return $! set l x ss+    opt l s = set l . Just <$> s+          <!> set l Nothing <$ atomSpec "clear" -    setFieldWithMb l p =-      do x <- case v of-                Atom "clear" -> return Nothing-                _            -> Just <$> p v-         return $! set l x ss+    settings =+      [ optSection' "name" "The name used to identify this server in the client"+      $ opt ssName valuesSpec+      , optSection' "hostname" "Hostname of server"+      $ req ssHostName stringSpec+      , optSection' "port" "Port number of server. Default 6667 without TLS or 6697 with TLS"+      $ opt ssPort numSpec+      , optSection' "nick" "Nicknames to connect with in order"+      $ req ssNicks nicksSpec+      , optSection' "password" "Server password"+      $ opt ssPassword valuesSpec+      , optSection' "username" "Second component of _!_@_ usermask"+      $ req ssUser valuesSpec+      , optSection' "realname" "\"GECOS\" name sent to server visible in /whois"+      $ req ssReal valuesSpec+      , optSection' "userinfo" "CTCP userinfo (currently unused)"+      $ req ssUserInfo valuesSpec+      , optSection' "sasl-username" "Username for SASL authentication to NickServ"+      $ opt ssSaslUsername valuesSpec+      , optSection' "sasl-password" "Password for SASL authentication to NickServ"+      $ opt ssSaslPassword valuesSpec+      , optSection' "sasl-ecdsa-key" "Path to ECDSA key for non-password SASL authentication"+      $ opt ssSaslEcdsaFile stringSpec+      , optSection' "tls" "Set to `yes` to enable secure connect. Set to `yes-insecure` to disable certificate checking."+      $ req ssTls useTlsSpec+      , optSection' "tls-client-cert" "Path to TLS client certificate"+      $ opt ssTlsClientCert stringSpec+      , optSection' "tls-client-key" "Path to TLS client key"+      $ opt ssTlsClientKey stringSpec+      , optSection' "tls-server-cert" "Path to CA certificate bundle"+      $ opt ssTlsServerCert stringSpec+      , optSection' "tls-ciphers" "OpenSSL cipher specification. Default to \"HIGH\""+      $ req ssTlsCiphers stringSpec+      , optSection' "socks-host" "Hostname of SOCKS5 proxy server"+      $ opt ssSocksHost stringSpec+      , optSection' "socks-port" "Port number of SOCKS5 proxy server"+      $ req ssSocksPort numSpec+      , optSection' "connect-cmds" "Command to be run upon successful connection to server"+      $ req ssConnectCmds $ listSpec macroCommandSpec+      , optSection' "chanserv-channels" "Channels with ChanServ permissions available"+      $ req ssChanservChannels  $ listSpec identifierSpec+      , optSection' "flood-penalty" "RFC 1459 rate limiting, seconds of penalty per message (default 2)"+      $ req ssFloodPenalty valuesSpec+      , optSection' "flood-threshold" "RFC 1459 rate limiting, seconds of allowed penalty accumulation (default 10)"+      $ req ssFloodThreshold valuesSpec+      , optSection' "message-hooks" "Special message hooks to enable: \"buffextras\" available"+      $ req ssMessageHooks valuesSpec+      , optSection' "reconnect-attempts" "Number of reconnection attempts on lost connection"+      $ req ssReconnectAttempts valuesSpec+      , optSection' "autoconnect" "Set to `yes` to automatically connect at client startup"+      $ req ssAutoconnect yesOrNoSpec+      , optSection' "nick-completion" "Behavior for nickname completion with TAB"+      $ req ssNickCompletion nickCompletionSpec+      , optSection' "log-dir" "Path to log file directory for this server"+      $ opt ssLogDir stringSpec+      ] -parseNicks :: Value -> ConfigParser (NonEmpty Text)-parseNicks (Text nick) = return (nick NonEmpty.:| [])-parseNicks (List xs) =-  do xs' <- parseList parseConfig (List xs)-     case xs' of-       [] -> failure "empty list"-       y:ys -> return (y NonEmpty.:| ys)-parseNicks _ = failure "expected text or list of text" -parseUseTls :: Value -> ConfigParser UseTls-parseUseTls (Atom "yes")          = return UseTls-parseUseTls (Atom "yes-insecure") = return UseInsecureTls-parseUseTls (Atom "no")           = return UseInsecure-parseUseTls _                     = failure "expected yes, yes-insecure, or no"+nicksSpec :: ValueSpecs (NonEmpty Text)+nicksSpec = pure <$> valuesSpec+        <!> nonemptyList valuesSpec -parseNum :: Num a => Value -> ConfigParser a-parseNum v = fromInteger <$> parseConfig v -parseIdentifier :: Value -> ConfigParser Identifier-parseIdentifier v = mkId <$> parseConfig v+useTlsSpec :: ValueSpecs UseTls+useTlsSpec =+      UseTls         <$ atomSpec "yes"+  <!> UseInsecureTls <$ atomSpec "yes-insecure"+  <!> UseInsecure    <$ atomSpec "no" -parseString :: Value -> ConfigParser String-parseString v = Text.unpack <$> parseConfig v+identifierSpec :: ValueSpecs Identifier+identifierSpec = mkId <$> valuesSpec  -- | Resolve relative paths starting at the home directory rather than -- the current directory of the client.@@ -340,34 +358,24 @@   | otherwise = do home <- getHomeDirectory                    return (home </> path) -parseMacroMap :: Value -> ConfigParser (Recognizer Macro)-parseMacroMap v = fromCommands <$> parseList parseMacro v+macroMapSpec :: ValueSpecs (Recognizer Macro)+macroMapSpec = fromCommands <$> listSpec macroValueSpecs -parseMacro :: Value -> ConfigParser (Text, Macro)-parseMacro = parseSections $-  do name     <- sectionReq "name"+macroValueSpecs :: ValueSpecs (Text, Macro)+macroValueSpecs = sectionsSpec "macro" $+  do name     <- reqSection "name" ""      spec     <- fromMaybe noMacroArguments-             <$> sectionOptWith parseMacroArguments "arguments"-     commands <- sectionReqWith (parseList parseMacroCommand) "commands"+             <$> optSection' "arguments" "" macroArgumentsSpec+     commands <- reqSection' "commands" "" (listSpec macroCommandSpec)      return (name, Macro spec commands) -parseMacroArguments :: Value -> ConfigParser MacroSpec-parseMacroArguments v =-  do txt <- parseConfig v-     case parseMacroSpecs txt of-       Nothing -> failure "bad macro argument specs"-       Just ex -> return ex+macroArgumentsSpec :: ValueSpecs MacroSpec+macroArgumentsSpec = customSpec "macro arguments" valuesSpec parseMacroSpecs -parseMacroCommand :: Value -> ConfigParser [ExpansionChunk]-parseMacroCommand v =-  do txt <- parseConfig v-     case parseExpansion txt of-       Nothing -> failure "bad macro line"-       Just ex -> return ex+macroCommandSpec :: ValueSpecs [ExpansionChunk]+macroCommandSpec = customSpec "macro command" valuesSpec parseExpansion -parseNickCompletion :: Value -> ConfigParser WordCompletionMode-parseNickCompletion v =-  case v of-    Atom "default" -> return defaultNickWordCompleteMode-    Atom "slack"   -> return slackNickWordCompleteMode-    _              -> failure "expected default or slack"+nickCompletionSpec :: ValueSpecs WordCompletionMode+nickCompletionSpec =+      defaultNickWordCompleteMode <$ atomSpec "default"+  <!> slackNickWordCompleteMode   <$ atomSpec "slack"

@@ -1,4 +1,5 @@ {-# Language OverloadedStrings #-}+{-# Language ApplicativeDo #-}  {-| Module      : Client.Configuration@@ -11,56 +12,50 @@ -}  module Client.Configuration.Colors-  ( parseColor-  , parseAttr+  ( colorSpec+  , attrSpec   ) where -import           Config-import           Config.FromConfig+import           Config.Schema+import           Control.Applicative import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap-import           Data.Foldable-import           Data.Ratio+import           Data.Functor.Alt ((<!>)) import           Data.Text (Text) import           Graphics.Vty.Attributes  -- | Parse a text attribute. This value should be a sections with the @fg@ and/or -- @bg@ attributes. Otherwise it should be a color entry that will be used -- for the foreground color. An empty sections value will result in 'defAttr'-parseAttr :: Value -> ConfigParser Attr-parseAttr (Sections xs) = parseSectionsWith parseAttrEntry defAttr (Sections xs)-parseAttr v             = withForeColor defAttr <$> parseColor v+attrSpec :: ValueSpecs Attr+attrSpec = namedSpec "attr" $+           withForeColor defAttr <$> colorSpec+       <!> fullAttrSpec -parseAttrEntry :: Attr -> Text -> Value -> ConfigParser Attr-parseAttrEntry acc k v =-    case k of-        "fg" -> parseColor' withForeColor-        "bg" -> parseColor' withBackColor-        "style" -> parseStyle'-        _    -> failure "Unknown attribute entry"+fullAttrSpec :: ValueSpecs Attr+fullAttrSpec = sectionsSpec "full-attr" $+  do mbFg <- optSection' "fg"    "Foreground color" colorSpec+     mbBg <- optSection' "bg"    "Background color" colorSpec+     mbSt <- optSection' "style" "Terminal font style" stylesSpec+     return ( aux withForeColor mbFg+            $ aux withBackColor mbBg+            $ aux (foldl withStyle) mbSt+            $ defAttr)   where-    parseStyle' =-      do xs <- parseStyles v-         return $! foldl' withStyle acc xs+    aux f xs z = foldl f z xs -    parseColor' f =-      do c <- parseColor v-         return $! f acc c -parseStyles :: Value -> ConfigParser [Style]-parseStyles (List xs) = parseList parseStyle (List xs)-parseStyles v         = pure <$> parseStyle v+stylesSpec :: ValueSpecs [Style]+stylesSpec = oneOrList styleSpec -parseStyle :: Value -> ConfigParser Style-parseStyle v =-  case v of-    Atom "blink"         -> pure blink -- You're the boss...-    Atom "bold"          -> pure bold-    Atom "dim"           -> pure dim-    Atom "reverse-video" -> pure reverseVideo-    Atom "standout"      -> pure standout-    Atom "underline"     -> pure underline-    _ -> failure "expected blink, bold, dim, reverse-video, standout, underline"+styleSpec :: ValueSpecs Style+styleSpec = namedSpec "style" $+      blink        <$ atomSpec "blink"+  <!> bold         <$ atomSpec "bold"+  <!> dim          <$ atomSpec "dim"+  <!> reverseVideo <$ atomSpec "reverse-video"+  <!> standout     <$ atomSpec "standout"+  <!> underline    <$ atomSpec "underline"   -- | Parse a color. Support formats are:@@ -68,46 +63,29 @@ -- * Number between 0-255 -- * Name of color -- * RGB values of color as a list-parseColor :: Value -> ConfigParser Color-parseColor v =-  case v of-    _ | Just i <- parseInteger v -> parseColorNumber i--    Atom a | Just c <- HashMap.lookup (atomName a) namedColors -> return c--    List [r,g,b]-      | Just r' <- parseInteger r-      , Just g' <- parseInteger g-      , Just b' <- parseInteger b ->-         parseRgb r' g' b'+colorSpec :: ValueSpecs Color+colorSpec = namedSpec "color" (colorNumberSpec <!> colorNameSpec <!> rgbSpec) -    _ -> failure "Expected a color number, name, or RBG list"+colorNameSpec :: ValueSpecs Color+colorNameSpec = customSpec "color name" anyAtomSpec (`HashMap.lookup` namedColors)  -- | Match integers between 0 and 255 as Terminal colors.-parseColorNumber :: Integer -> ConfigParser Color-parseColorNumber i-  | i < 0 = failure "Negative color not supported"-  | i < 16 = return (ISOColor (fromInteger i))-  | i < 256 = return (Color240 (fromInteger (i - 16)))-  | otherwise = failure "Color value too high"---- | Accepts any integer literal or floating literal which can--- be losslessly converted to an integer.-parseInteger :: Value -> Maybe Integer-parseInteger v =-  case v of-    Number _ i -> Just i-    Floating c e-      | denominator r == 1 -> Just (numerator r)-      where r = fromInteger c * 10^^e-    _ -> Nothing+colorNumberSpec :: ValueSpecs Color+colorNumberSpec = customSpec "terminal color" valuesSpec $ \i ->+  if      i <   0 then Nothing+  else if i <  16 then Just (ISOColor (fromInteger i))+  else if i < 256 then Just (Color240 (fromInteger (i - 16)))+  else Nothing -parseRgb :: Integer -> Integer -> Integer -> ConfigParser Color-parseRgb r g b-  | valid r, valid g, valid b = return (rgbColor r g b)-  | otherwise = failure "RGB values must be in range 0-255"+-- | Configuration section that matches 3 integers in the range 0-255+-- representing red, green, and blue values.+rgbSpec :: ValueSpecs Color+rgbSpec = customSpec "RGB" valuesSpec $ \rgb ->+  case rgb of+    [r,g,b] | valid r, valid g, valid b -> Just (rgbColor r g b)+    _                                   -> Nothing   where-    valid x = 0 <= x && x < 256+    valid x = 0 <= x && x < (256 :: Integer)  namedColors :: HashMap Text Color namedColors = HashMap.fromList

@@ -396,7 +396,7 @@     Just n  -> intercalate " "              $ map (\(u,i) -> show i ++ [u])              $ dropWhile (\x -> snd x == 0)-             $ zip "dhms" [d,h,m,s]+             $ zip "dhms" [d,h,m,s :: Int]       where         (n1,s) = quotRem n  60         (n2,m) = quotRem n1 60

@@ -43,7 +43,6 @@ import           Control.Lens import           Control.Monad import           Data.ByteString (ByteString)-import qualified Data.ByteString as B import           Data.Foldable import           Data.Time import           Irc.RateLimit

@@ -23,8 +23,6 @@ import           Control.Applicative import           Control.Exception  (bracket) import           Control.Lens-import           Control.Monad-import           Data.Monoid        ((<>)) import           Network.Socket     (PortNumber) import           Hookup 

@@ -32,11 +32,13 @@   , getOptions   ) where +import           Config.Schema.Docs import           Control.Lens import           Data.Foldable import           Data.List import           Data.Text (Text) import qualified Data.Text as Text+import qualified Data.Text.IO as Text import           Data.Version import           Development.GitRev (gitHash, gitDirty) import           System.Console.GetOpt@@ -47,6 +49,8 @@ import           Paths_glirc (version) import           Build_glirc (deps) +import           Client.Configuration+ -- | Command-line options data Options = Options   { _optConfigFile      :: Maybe FilePath -- ^ configuration file path@@ -55,6 +59,7 @@   , _optShowHelp        :: Bool           -- ^ show help message   , _optShowVersion     :: Bool           -- ^ show version message   , _optShowFullVersion :: Bool           -- ^ show version of ALL transitive dependencies+  , _optShowConfigFormat:: Bool           -- ^ show configuration file format   }  makeLenses ''Options@@ -68,6 +73,7 @@   , _optShowVersion     = False   , _optShowFullVersion = False   , _optNoConnect       = False+  , _optShowConfigFormat= False   }  -- | Option descriptions@@ -79,6 +85,8 @@     "Disable autoconnecting"   , Option "h" ["help"]    (NoArg (set optShowHelp True))     "Show help"+  , Option "" ["config-format"] (NoArg (set optShowConfigFormat True))+    "Show configuration file format"   , Option "v" ["version"] (NoArg (set optShowVersion True))     "Show version"   , Option "" ["full-version"] (NoArg (set optShowFullVersion True))@@ -103,11 +111,12 @@               traverse_ (hPutStr stderr) (map bullet errors)               hPutStrLn stderr tryHelpTxt -     if | view optShowHelp    opts -> putStr helpTxt    >> exitSuccess+     if | view optShowHelp    opts -> putStr helpTxt >> exitSuccess         | view optShowFullVersion opts -> putStr fullVersionTxt >> exitSuccess         | view optShowVersion opts -> putStr versionTxt >> exitSuccess+        | view optShowConfigFormat opts -> Text.putStr (generateDocs configurationSpec) >> exitSuccess         | null errors              -> return opts-        | otherwise                -> reportErrors      >> exitFailure+        | otherwise                -> reportErrors >> exitFailure  helpTxt :: String helpTxt = usageInfo "glirc2 [FLAGS] INITIAL_NETWORKS..." options

@@ -1,208 +0,0 @@-{-# Language GeneralizedNewtypeDeriving #-}-{-# Language OverloadedStrings #-}--{-|-Module      : Config.FromConfig-Description : Parser for unstructure configuration file format-Copyright   : (c) Eric Mertens, 2016-License     : ISC-Maintainer  : emertens@gmail.com--This module provides tools for producing structured configuration-information out of configuration values.---}-module Config.FromConfig-  ( -- * Configuration parsing-    ConfigParser-  , decodeConfig-  , runConfigParser-  , failure-  , extendLoc-  , FromConfig(parseConfig)--  -- * Parser wrappers-  , parseList--  -- * Section parsing-  , SectionParser-  , parseSections-  , sectionReq-  , sectionReqWith-  , sectionOpt-  , sectionOptWith-  , liftConfigParser-  , parseSectionsWith-  ) where--import           Config-import           Control.Lens hiding (List)-import           Control.Monad-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Reader-import           Control.Monad.Trans.State-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.HashSet as HashSet-import           Data.Monoid-import           Data.Ratio-import           Data.Text (Text)-import qualified Data.Text as Text---- | Configuration parser tracking current location and for propagating--- error information.-newtype ConfigParser a = ConfigParser (ReaderT [Text] (Either Text) a)-  deriving (Functor, Applicative, Monad)---- | Run a top-level parser to either get the parsed value or an error message.-runConfigParser :: ConfigParser a -> Either Text a-runConfigParser (ConfigParser p) = runReaderT p []---- | A parser that always fails with the given error message.-failure :: Text {- ^ error message -} -> ConfigParser a-failure msg = ConfigParser $-  do loc <- ask-     let msg' = Text.concat [Text.intercalate "." (reverse loc), ": ", msg]-     lift (Left msg')---- | Embed a parser into an extended location. This is used when--- parsing inside a section.-extendLoc :: Text -> ConfigParser a -> ConfigParser a-extendLoc loc (ConfigParser p) = ConfigParser (local (loc:) p)------------------------------------------------------------------------------ | Parse a 'Value' according to the method in the 'FromConfig'-decodeConfig :: FromConfig a => Value -> Either Text a-decodeConfig = runConfigParser . parseConfig---- | Class for types that have a well-known way to parse them.-class FromConfig a where-  -- | Parse a value-  parseConfig :: Value -> ConfigParser a---- | Matches 'Text' values.-instance FromConfig Text where-  parseConfig (Text x)          = return x-  parseConfig _                 = failure "expected text"---- | Matches @yes@ as 'True' and @no@ as 'False.-instance FromConfig Bool where-  parseConfig (Atom "yes")      = return True-  parseConfig (Atom "no")       = return False-  parseConfig _                 = failure "expected yes or no"---- | Matches 'Number' values ignoring the base-instance FromConfig Integer where-  parseConfig (Number _ n)      = return n-  parseConfig (Floating c e)-    | denominator n == 1 = return $! numerator n-    where-      n = floatingToRatio c e-  parseConfig _                 = failure "expected integral number"--instance FromConfig Int where-  parseConfig v =-    do i <- parseConfig v-       let small = minBound :: Int-           large = maxBound :: Int-       when (i < toInteger small || toInteger large < i)-          (failure "int out of range")-       return (fromInteger i)---- | Matches 'Number' values ignoring the base-instance Integral a => FromConfig (Ratio a) where-  parseConfig (Number _ n)   = return $! fromIntegral n-  parseConfig (Floating c e) = return $! floatingToRatio c e-  parseConfig _              = failure "expected fractional number"---- | Matches 'Atom' values-instance FromConfig Atom where-  parseConfig (Atom a)          = return a-  parseConfig _                 = failure "expected atom"---- | Matches 'List' values, extends the error location with a zero-based--- index-instance FromConfig a => FromConfig [a] where-  parseConfig = parseList parseConfig------------------------------------------------------------------------------ | Parser for consuming key-value pairs of sections.-newtype SectionParser a =-  SectionParser (StateT (HashMap Text Value) ConfigParser a)-  deriving (Functor, Applicative, Monad)---- | Lift a 'ConfigParser' into a 'SectionParser' leaving the current--- section information unmodified.-liftConfigParser :: ConfigParser a -> SectionParser a-liftConfigParser = SectionParser . lift---- | Run a 'SectionParser' given particular 'Value'. This will only--- succeed when the value is a 'Sections' and the section parser consumes all--- of the sections from that value.-parseSections :: SectionParser a -> Value -> ConfigParser a-parseSections (SectionParser p) (Sections xs) =-  do hm <- toHashMap xs-     (res, xs') <- runStateT p hm-     let unused = HashMap.keys xs'-     unless (null unused)-       (failure ("unknown keys: " <> Text.intercalate ", " unused))-     return res-parseSections _ _ = failure "expected sections"---- |--- @--- sectionOpt = sectionOptWith parseConfig--- @-sectionOpt :: FromConfig a => Text -> SectionParser (Maybe a)-sectionOpt = sectionOptWith parseConfig---- | Parses the value stored at the given section with the given parser.--- Nothing is returned if the section is missing.--- Just is returned if the parse succeeds--- Error is raised if the section is present but the parse fails-sectionOptWith :: (Value -> ConfigParser a) -> Text -> SectionParser (Maybe a)-sectionOptWith p key = SectionParser $-  do mb <- at key <<.= Nothing-     lift (traverse (extendLoc key . p) mb)---- | Parse the value at the given section or fail.-sectionReq :: FromConfig a => Text -> SectionParser a-sectionReq = sectionReqWith parseConfig---- | Parse the value at the given section or fail.-sectionReqWith :: (Value -> ConfigParser a) -> Text -> SectionParser a-sectionReqWith p key =-  do mb <- sectionOptWith p key-     liftConfigParser $ case mb of-                          Nothing -> failure ("section required: " <> key)-                          Just x  -> return x--toHashMap :: [Section] -> ConfigParser (HashMap Text Value)-toHashMap xs =-  case duplicateCheck xs of-    Just key -> failure ("duplicate section: " <> key)-    Nothing  -> return $! HashMap.fromList [ (k,v) | Section k v <- xs ]--duplicateCheck :: [Section] -> Maybe Text-duplicateCheck = go HashSet.empty-  where-    go _ [] = Nothing-    go seen (Section x _:xs)-      | HashSet.member x seen = Just x-      | otherwise             = go (HashSet.insert x seen) xs--floatingToRatio :: Integral a => Integer -> Integer -> Ratio a-floatingToRatio c e = fromIntegral c * 10 ^^ e--parseSectionsWith :: (a -> Text -> Value -> ConfigParser a) -> a -> Value -> ConfigParser a-parseSectionsWith p start s =-  case s of-    Sections xs -> foldM (\x (Section k v) -> extendLoc k (p x k v)) start xs-    _ -> failure "Expected sections"--parseList :: (Value -> ConfigParser a) -> Value -> ConfigParser [a]-parseList p (List xs) = ifor xs $ \i x ->-                          extendLoc (Text.pack (show (i+1))) (p x)-parseList _ _         = failure "expected list"