{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards,
    ScopedTypeVariables, TupleSections #-}

-- |
-- Module:      Data.Configurator
-- Copyright:   (c) 2011 MailRank, Inc.
-- License:     BSD3
-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
-- Stability:   experimental
-- Portability: portable
--
-- A simple (yet powerful) library for working with configuration
-- files.

module Data.Configurator
    (
    -- * Configuration file format
    -- $format

    -- ** Binding a name to a value
    -- $binding

    -- *** Value types
    -- $types

    -- *** String interpolation
    -- $interp

    -- ** Grouping directives
    -- $group

    -- ** Importing files
    -- $import

    -- * Types
      Worth(..)
    -- * Loading configuration data
    , autoReload
    , autoReloadGroups
    , autoConfig
    , empty
    -- * Lookup functions
    , lookup
    , lookupDefault
    , require
    -- * Notification of configuration changes
    -- $notify
    , prefix
    , exact
    , subscribe
    -- * Low-level loading functions
    , load
    , loadGroups
    , reload
    , subconfig
    , addToConfig
    , addGroupsToConfig
    -- * Helper functions
    , display
    , getMap
    ) where

import Control.Applicative ((<$>))
import Control.Concurrent (ThreadId, forkIO, threadDelay)
import Control.Exception (SomeException, evaluate, handle, throwIO, try)
import Control.Monad (foldM, forM, forM_, join, when, msum)
import Data.Configurator.Instances ()
import Data.Configurator.Parser (interp, topLevel)
import Data.Configurator.Types.Internal
import Data.IORef (atomicModifyIORef, newIORef, readIORef)
import Data.List (tails)
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid (mconcat)
import Data.Ratio (denominator, numerator)
import Data.Text.Lazy.Builder (fromString, fromText, toLazyText)
import Data.Text.Lazy.Builder.Int (decimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
import Prelude hiding (lookup)
import System.Environment (getEnv)
import System.IO (hPutStrLn, stderr)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types (EpochTime, FileOffset)
import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
import qualified Control.Exception as E
import qualified Data.Attoparsec.Text as T
import qualified Data.Attoparsec.Text.Lazy as L
import qualified Data.HashMap.Lazy as H
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.IO as L

loadFiles :: [Worth Path] -> IO (H.HashMap (Worth Path) [Directive])
loadFiles :: [Worth Text] -> IO (HashMap (Worth Text) [Directive])
loadFiles = (HashMap (Worth Text) [Directive]
 -> Worth Text -> IO (HashMap (Worth Text) [Directive]))
-> HashMap (Worth Text) [Directive]
-> [Worth Text]
-> IO (HashMap (Worth Text) [Directive])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HashMap (Worth Text) [Directive]
-> Worth Text -> IO (HashMap (Worth Text) [Directive])
go HashMap (Worth Text) [Directive]
forall k v. HashMap k v
H.empty
 where
   go :: HashMap (Worth Text) [Directive]
-> Worth Text -> IO (HashMap (Worth Text) [Directive])
go HashMap (Worth Text) [Directive]
seen Worth Text
path = do
     let rewrap :: b -> Worth b
rewrap b
n = b -> Text -> b
forall a b. a -> b -> a
const b
n (Text -> b) -> Worth Text -> Worth b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Worth Text
path
         wpath :: Text
wpath = Worth Text -> Text
forall a. Worth a -> a
worth Worth Text
path
     path' <- Text -> Worth Text
forall {b}. b -> Worth b
rewrap (Text -> Worth Text) -> IO Text -> IO (Worth Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> HashMap Text Value -> IO Text
interpolate Text
"" Text
wpath HashMap Text Value
forall k v. HashMap k v
H.empty
     ds    <- loadOne (T.unpack <$> path')
     let !seen'    = Worth Text
-> [Directive]
-> HashMap (Worth Text) [Directive]
-> HashMap (Worth Text) [Directive]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Worth Text
path [Directive]
ds HashMap (Worth Text) [Directive]
seen
         notSeen Worth Text
n = Bool -> Bool
not (Bool -> Bool)
-> (HashMap (Worth Text) [Directive] -> Bool)
-> HashMap (Worth Text) [Directive]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Directive] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [Directive] -> Bool)
-> (HashMap (Worth Text) [Directive] -> Maybe [Directive])
-> HashMap (Worth Text) [Directive]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Worth Text -> HashMap (Worth Text) [Directive] -> Maybe [Directive]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Worth Text
n (HashMap (Worth Text) [Directive] -> Bool)
-> HashMap (Worth Text) [Directive] -> Bool
forall a b. (a -> b) -> a -> b
$ HashMap (Worth Text) [Directive]
seen
     foldM go seen' . filter notSeen . importsOf wpath $ ds

-- | Create a 'Config' from the contents of the named files. Throws an
-- exception on error, such as if files do not exist or contain errors.
--
-- File names have any environment variables expanded prior to the
-- first time they are opened, so you can specify a file name such as
-- @\"$(HOME)/myapp.cfg\"@.
load :: [Worth FilePath] -> IO Config
load :: [Worth String] -> IO Config
load [Worth String]
files = (BaseConfig -> Config) -> IO BaseConfig -> IO Config
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> BaseConfig -> Config
Config Text
"") (IO BaseConfig -> IO Config) -> IO BaseConfig -> IO Config
forall a b. (a -> b) -> a -> b
$ Maybe AutoConfig -> [(Text, Worth String)] -> IO BaseConfig
load' Maybe AutoConfig
forall a. Maybe a
Nothing ((Worth String -> (Text, Worth String))
-> [Worth String] -> [(Text, Worth String)]
forall a b. (a -> b) -> [a] -> [b]
map (\Worth String
f -> (Text
"", Worth String
f)) [Worth String]
files)

-- | Create a 'Config' from the contents of the named files, placing them
-- into named prefixes.  If a prefix is non-empty, it should end in a
-- dot.
loadGroups :: [(Name, Worth FilePath)] -> IO Config
loadGroups :: [(Text, Worth String)] -> IO Config
loadGroups [(Text, Worth String)]
files = (BaseConfig -> Config) -> IO BaseConfig -> IO Config
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> BaseConfig -> Config
Config Text
"") (IO BaseConfig -> IO Config) -> IO BaseConfig -> IO Config
forall a b. (a -> b) -> a -> b
$ Maybe AutoConfig -> [(Text, Worth String)] -> IO BaseConfig
load' Maybe AutoConfig
forall a. Maybe a
Nothing [(Text, Worth String)]
files

load' :: Maybe AutoConfig -> [(Name, Worth FilePath)] -> IO BaseConfig
load' :: Maybe AutoConfig -> [(Text, Worth String)] -> IO BaseConfig
load' Maybe AutoConfig
auto [(Text, Worth String)]
paths0 = do
  let second :: (t -> b) -> (a, t) -> (a, b)
second t -> b
f (a
x,t
y) = (a
x, t -> b
f t
y)
      paths :: [(Text, Worth Text)]
paths          = ((Text, Worth String) -> (Text, Worth Text))
-> [(Text, Worth String)] -> [(Text, Worth Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Worth String -> Worth Text)
-> (Text, Worth String) -> (Text, Worth Text)
forall {t} {b} {a}. (t -> b) -> (a, t) -> (a, b)
second ((String -> Text) -> Worth String -> Worth Text
forall a b. (a -> b) -> Worth a -> Worth b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack)) [(Text, Worth String)]
paths0
  ds <- [Worth Text] -> IO (HashMap (Worth Text) [Directive])
loadFiles (((Text, Worth Text) -> Worth Text)
-> [(Text, Worth Text)] -> [Worth Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Worth Text) -> Worth Text
forall a b. (a, b) -> b
snd [(Text, Worth Text)]
paths)
  p <- newIORef paths
  m <- newIORef =<< flatten paths ds
  s <- newIORef H.empty
  return BaseConfig {
                cfgAuto = auto
              , cfgPaths = p
              , cfgMap = m
              , cfgSubs = s
              }

-- | Gives a 'Config' corresponding to just a single group of the original
-- 'Config'.  The subconfig can be used just like the original 'Config', but
-- see the documentation for 'reload'.
subconfig :: Name -> Config -> Config
subconfig :: Text -> Config -> Config
subconfig Text
g (Config Text
root BaseConfig
cfg) = Text -> BaseConfig -> Config
Config ([Text] -> Text
T.concat [Text
root, Text
g, Text
"."]) BaseConfig
cfg

-- | Forcibly reload a 'Config'. Throws an exception on error, such as
-- if files no longer exist or contain errors.  If the provided 'Config' is
-- a 'subconfig', this will reload the entire top-level configuration, not just
-- the local section.
reload :: Config -> IO ()
reload :: Config -> IO ()
reload (Config Text
_ cfg :: BaseConfig
cfg@BaseConfig{Maybe AutoConfig
IORef [(Text, Worth Text)]
IORef (HashMap Text Value)
IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: BaseConfig -> Maybe AutoConfig
cfgPaths :: BaseConfig -> IORef [(Text, Worth Text)]
cfgMap :: BaseConfig -> IORef (HashMap Text Value)
cfgSubs :: BaseConfig -> IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: Maybe AutoConfig
cfgPaths :: IORef [(Text, Worth Text)]
cfgMap :: IORef (HashMap Text Value)
cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
..}) = BaseConfig -> IO ()
reloadBase BaseConfig
cfg

reloadBase :: BaseConfig -> IO ()
reloadBase :: BaseConfig -> IO ()
reloadBase cfg :: BaseConfig
cfg@BaseConfig{Maybe AutoConfig
IORef [(Text, Worth Text)]
IORef (HashMap Text Value)
IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: BaseConfig -> Maybe AutoConfig
cfgPaths :: BaseConfig -> IORef [(Text, Worth Text)]
cfgMap :: BaseConfig -> IORef (HashMap Text Value)
cfgSubs :: BaseConfig -> IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: Maybe AutoConfig
cfgPaths :: IORef [(Text, Worth Text)]
cfgMap :: IORef (HashMap Text Value)
cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
..} = do
  paths <- IORef [(Text, Worth Text)] -> IO [(Text, Worth Text)]
forall a. IORef a -> IO a
readIORef IORef [(Text, Worth Text)]
cfgPaths
  m' <- flatten paths =<< loadFiles (map snd paths)
  m <- atomicModifyIORef cfgMap $ \HashMap Text Value
m -> (HashMap Text Value
m', HashMap Text Value
m)
  notifySubscribers cfg m m' =<< readIORef cfgSubs

-- | Add additional files to a 'Config', causing it to be reloaded to add
-- their contents.
addToConfig :: [Worth FilePath] -> Config -> IO ()
addToConfig :: [Worth String] -> Config -> IO ()
addToConfig [Worth String]
paths0 Config
cfg = [(Text, Worth String)] -> Config -> IO ()
addGroupsToConfig ((Worth String -> (Text, Worth String))
-> [Worth String] -> [(Text, Worth String)]
forall a b. (a -> b) -> [a] -> [b]
map (\Worth String
x -> (Text
"",Worth String
x)) [Worth String]
paths0) Config
cfg

-- | Add additional files to named groups in a 'Config', causing it to be
-- reloaded to add their contents.  If the prefixes are non-empty, they should
-- end in dots.
addGroupsToConfig :: [(Name, Worth FilePath)] -> Config -> IO ()
addGroupsToConfig :: [(Text, Worth String)] -> Config -> IO ()
addGroupsToConfig [(Text, Worth String)]
paths0 (Config Text
root cfg :: BaseConfig
cfg@BaseConfig{Maybe AutoConfig
IORef [(Text, Worth Text)]
IORef (HashMap Text Value)
IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: BaseConfig -> Maybe AutoConfig
cfgPaths :: BaseConfig -> IORef [(Text, Worth Text)]
cfgMap :: BaseConfig -> IORef (HashMap Text Value)
cfgSubs :: BaseConfig -> IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: Maybe AutoConfig
cfgPaths :: IORef [(Text, Worth Text)]
cfgMap :: IORef (HashMap Text Value)
cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
..}) = do
  let fix :: (Text, f String) -> (Text, f Text)
fix (Text
x,f String
y) = (Text
root Text -> Text -> Text
`T.append` Text
x, (String -> Text) -> f String -> f Text
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack f String
y)
      paths :: [(Text, Worth Text)]
paths     = ((Text, Worth String) -> (Text, Worth Text))
-> [(Text, Worth String)] -> [(Text, Worth Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Worth String) -> (Text, Worth Text)
forall {f :: * -> *}.
Functor f =>
(Text, f String) -> (Text, f Text)
fix [(Text, Worth String)]
paths0
  IORef [(Text, Worth Text)]
-> ([(Text, Worth Text)] -> ([(Text, Worth Text)], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [(Text, Worth Text)]
cfgPaths (([(Text, Worth Text)] -> ([(Text, Worth Text)], ())) -> IO ())
-> ([(Text, Worth Text)] -> ([(Text, Worth Text)], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Text, Worth Text)]
prev -> ([(Text, Worth Text)]
prev [(Text, Worth Text)]
-> [(Text, Worth Text)] -> [(Text, Worth Text)]
forall a. [a] -> [a] -> [a]
++ [(Text, Worth Text)]
paths, ())
  BaseConfig -> IO ()
reloadBase BaseConfig
cfg

-- | Defaults for automatic 'Config' reloading when using
-- 'autoReload'.  The 'interval' is one second, while the 'onError'
-- action ignores its argument and does nothing.
autoConfig :: AutoConfig
autoConfig :: AutoConfig
autoConfig = AutoConfig {
               interval :: Int
interval = Int
1
             , onError :: SomeException -> IO ()
onError = IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const (IO () -> SomeException -> IO ())
-> IO () -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             }

-- | Load a 'Config' from the given 'FilePath's, and start a reload
-- thread.
--
-- At intervals, a thread checks for modifications to both the
-- original files and any files they refer to in @import@ directives,
-- and reloads the 'Config' if any files have been modified.
--
-- If the initial attempt to load the configuration files fails, an
-- exception is thrown.  If the initial load succeeds, but a
-- subsequent attempt fails, the 'onError' handler is invoked.
--
-- File names have any environment variables expanded prior to the
-- first time they are opened, so you can specify a file name such as
-- @\"$(HOME)/myapp.cfg\"@.
autoReload :: AutoConfig
           -- ^ Directions for when to reload and how to handle
           -- errors.
           -> [Worth FilePath]
           -- ^ Configuration files to load.
           -> IO (Config, ThreadId)
autoReload :: AutoConfig -> [Worth String] -> IO (Config, ThreadId)
autoReload AutoConfig
auto [Worth String]
paths = AutoConfig -> [(Text, Worth String)] -> IO (Config, ThreadId)
autoReloadGroups AutoConfig
auto ((Worth String -> (Text, Worth String))
-> [Worth String] -> [(Text, Worth String)]
forall a b. (a -> b) -> [a] -> [b]
map (\Worth String
x -> (Text
"", Worth String
x)) [Worth String]
paths)

autoReloadGroups :: AutoConfig
                 -> [(Name, Worth FilePath)]
                 -> IO (Config, ThreadId)
autoReloadGroups :: AutoConfig -> [(Text, Worth String)] -> IO (Config, ThreadId)
autoReloadGroups AutoConfig{Int
SomeException -> IO ()
interval :: AutoConfig -> Int
onError :: AutoConfig -> SomeException -> IO ()
interval :: Int
onError :: SomeException -> IO ()
..} [(Text, Worth String)]
_
    | Int
interval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1    = String -> IO (Config, ThreadId)
forall a. HasCallStack => String -> a
error String
"autoReload: negative interval"
autoReloadGroups AutoConfig
_ [] = String -> IO (Config, ThreadId)
forall a. HasCallStack => String -> a
error String
"autoReload: no paths to load"
autoReloadGroups auto :: AutoConfig
auto@AutoConfig{Int
SomeException -> IO ()
interval :: AutoConfig -> Int
onError :: AutoConfig -> SomeException -> IO ()
interval :: Int
onError :: SomeException -> IO ()
..} [(Text, Worth String)]
paths = do
  cfg <- Maybe AutoConfig -> [(Text, Worth String)] -> IO BaseConfig
load' (AutoConfig -> Maybe AutoConfig
forall a. a -> Maybe a
Just AutoConfig
auto) [(Text, Worth String)]
paths
  let files = ((Text, Worth String) -> Worth String)
-> [(Text, Worth String)] -> [Worth String]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Worth String) -> Worth String
forall a b. (a, b) -> b
snd [(Text, Worth String)]
paths
      loop [Maybe Meta]
meta = do
        Int -> IO ()
threadDelay (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
interval Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
        meta' <- [Worth String] -> IO [Maybe Meta]
getMeta [Worth String]
files
        if meta' == meta
          then loop meta
          else (reloadBase cfg `E.catch` onError) >> loop meta'
  tid <- forkIO $ loop =<< getMeta files
  return (Config "" cfg, tid)

-- | Save both a file's size and its last modification date, so we
-- have a better chance of detecting a modification on a crappy
-- filesystem with timestamp resolution of 1 second or worse.
type Meta = (FileOffset, EpochTime)

getMeta :: [Worth FilePath] -> IO [Maybe Meta]
getMeta :: [Worth String] -> IO [Maybe Meta]
getMeta [Worth String]
paths = [Worth String]
-> (Worth String -> IO (Maybe Meta)) -> IO [Maybe Meta]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Worth String]
paths ((Worth String -> IO (Maybe Meta)) -> IO [Maybe Meta])
-> (Worth String -> IO (Maybe Meta)) -> IO [Maybe Meta]
forall a b. (a -> b) -> a -> b
$ \Worth String
path ->
   (SomeException -> IO (Maybe Meta))
-> IO (Maybe Meta) -> IO (Maybe Meta)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
_::SomeException) -> Maybe Meta -> IO (Maybe Meta)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Meta
forall a. Maybe a
Nothing) (IO (Maybe Meta) -> IO (Maybe Meta))
-> (IO Meta -> IO (Maybe Meta)) -> IO Meta -> IO (Maybe Meta)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Meta -> Maybe Meta) -> IO Meta -> IO (Maybe Meta)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Meta -> Maybe Meta
forall a. a -> Maybe a
Just (IO Meta -> IO (Maybe Meta)) -> IO Meta -> IO (Maybe Meta)
forall a b. (a -> b) -> a -> b
$ do
     st <- String -> IO FileStatus
getFileStatus (Worth String -> String
forall a. Worth a -> a
worth Worth String
path)
     return (fileSize st, modificationTime st)

-- | Look up a name in the given 'Config'.  If a binding exists, and
-- the value can be 'convert'ed to the desired type, return the
-- converted value, otherwise 'Nothing'.
lookup :: Configured a => Config -> Name -> IO (Maybe a)
lookup :: forall a. Configured a => Config -> Text -> IO (Maybe a)
lookup (Config Text
root BaseConfig{Maybe AutoConfig
IORef [(Text, Worth Text)]
IORef (HashMap Text Value)
IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: BaseConfig -> Maybe AutoConfig
cfgPaths :: BaseConfig -> IORef [(Text, Worth Text)]
cfgMap :: BaseConfig -> IORef (HashMap Text Value)
cfgSubs :: BaseConfig -> IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: Maybe AutoConfig
cfgPaths :: IORef [(Text, Worth Text)]
cfgMap :: IORef (HashMap Text Value)
cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
..}) Text
name =
    (Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a)
-> (HashMap Text Value -> Maybe (Maybe a))
-> HashMap Text Value
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Maybe a) -> Maybe Value -> Maybe (Maybe a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Maybe a
forall a. Configured a => Value -> Maybe a
convert (Maybe Value -> Maybe (Maybe a))
-> (HashMap Text Value -> Maybe Value)
-> HashMap Text Value
-> Maybe (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (Text
root Text -> Text -> Text
`T.append` Text
name)) (HashMap Text Value -> Maybe a)
-> IO (HashMap Text Value) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (HashMap Text Value) -> IO (HashMap Text Value)
forall a. IORef a -> IO a
readIORef IORef (HashMap Text Value)
cfgMap

-- | Look up a name in the given 'Config'.  If a binding exists, and
-- the value can be 'convert'ed to the desired type, return the
-- converted value, otherwise throw a 'KeyError'.
require :: Configured a => Config -> Name -> IO a
require :: forall a. Configured a => Config -> Text -> IO a
require Config
cfg Text
name = do
  val <- Config -> Text -> IO (Maybe a)
forall a. Configured a => Config -> Text -> IO (Maybe a)
lookup Config
cfg Text
name
  case val of
    Just a
v -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
    Maybe a
_      -> KeyError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (KeyError -> IO a) -> (Text -> KeyError) -> Text -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> KeyError
KeyError (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$ Text
name

-- | Look up a name in the given 'Config'.  If a binding exists, and
-- the value can be converted to the desired type, return it,
-- otherwise return the default value.
lookupDefault :: Configured a =>
                 a
              -- ^ Default value to return if 'lookup' or 'convert'
              -- fails.
              -> Config -> Name -> IO a
lookupDefault :: forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault a
def Config
cfg Text
name = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def (Maybe a -> a) -> IO (Maybe a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Text -> IO (Maybe a)
forall a. Configured a => Config -> Text -> IO (Maybe a)
lookup Config
cfg Text
name

-- | Perform a simple dump of a 'Config' to @stdout@.
display :: Config -> IO ()
display :: Config -> IO ()
display (Config Text
root BaseConfig{Maybe AutoConfig
IORef [(Text, Worth Text)]
IORef (HashMap Text Value)
IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: BaseConfig -> Maybe AutoConfig
cfgPaths :: BaseConfig -> IORef [(Text, Worth Text)]
cfgMap :: BaseConfig -> IORef (HashMap Text Value)
cfgSubs :: BaseConfig -> IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: Maybe AutoConfig
cfgPaths :: IORef [(Text, Worth Text)]
cfgMap :: IORef (HashMap Text Value)
cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
..}) = (Text, HashMap Text Value) -> IO ()
forall a. Show a => a -> IO ()
print ((Text, HashMap Text Value) -> IO ())
-> (HashMap Text Value -> (Text, HashMap Text Value))
-> HashMap Text Value
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
root,) (HashMap Text Value -> IO ()) -> IO (HashMap Text Value) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (HashMap Text Value) -> IO (HashMap Text Value)
forall a. IORef a -> IO a
readIORef IORef (HashMap Text Value)
cfgMap

-- | Fetch the 'H.HashMap' that maps names to values.
getMap :: Config -> IO (H.HashMap Name Value)
getMap :: Config -> IO (HashMap Text Value)
getMap = IORef (HashMap Text Value) -> IO (HashMap Text Value)
forall a. IORef a -> IO a
readIORef (IORef (HashMap Text Value) -> IO (HashMap Text Value))
-> (Config -> IORef (HashMap Text Value))
-> Config
-> IO (HashMap Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseConfig -> IORef (HashMap Text Value)
cfgMap (BaseConfig -> IORef (HashMap Text Value))
-> (Config -> BaseConfig) -> Config -> IORef (HashMap Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> BaseConfig
baseCfg

flatten :: [(Name, Worth Path)]
        -> H.HashMap (Worth Path) [Directive]
        -> IO (H.HashMap Name Value)
flatten :: [(Text, Worth Text)]
-> HashMap (Worth Text) [Directive] -> IO (HashMap Text Value)
flatten [(Text, Worth Text)]
roots HashMap (Worth Text) [Directive]
files = (HashMap Text Value
 -> (Text, Worth Text) -> IO (HashMap Text Value))
-> HashMap Text Value
-> [(Text, Worth Text)]
-> IO (HashMap Text Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HashMap Text Value -> (Text, Worth Text) -> IO (HashMap Text Value)
doPath HashMap Text Value
forall k v. HashMap k v
H.empty [(Text, Worth Text)]
roots
 where
  doPath :: HashMap Text Value -> (Text, Worth Text) -> IO (HashMap Text Value)
doPath HashMap Text Value
m (Text
pfx, Worth Text
f) = case Worth Text -> HashMap (Worth Text) [Directive] -> Maybe [Directive]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Worth Text
f HashMap (Worth Text) [Directive]
files of
        Maybe [Directive]
Nothing -> HashMap Text Value -> IO (HashMap Text Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HashMap Text Value
m
        Just [Directive]
ds -> (HashMap Text Value -> Directive -> IO (HashMap Text Value))
-> HashMap Text Value -> [Directive] -> IO (HashMap Text Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Text
-> Text
-> HashMap Text Value
-> Directive
-> IO (HashMap Text Value)
directive Text
pfx (Worth Text -> Text
forall a. Worth a -> a
worth Worth Text
f)) HashMap Text Value
m [Directive]
ds

  directive :: Text
-> Text
-> HashMap Text Value
-> Directive
-> IO (HashMap Text Value)
directive Text
pfx Text
_ HashMap Text Value
m (Bind Text
name (String Text
value)) = do
      v <- Text -> Text -> HashMap Text Value -> IO Text
interpolate Text
pfx Text
value HashMap Text Value
m
      return $! H.insert (T.append pfx name) (String v) m
  directive Text
pfx Text
_ HashMap Text Value
m (Bind Text
name Value
value) =
      HashMap Text Value -> IO (HashMap Text Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap Text Value -> IO (HashMap Text Value))
-> HashMap Text Value -> IO (HashMap Text Value)
forall a b. (a -> b) -> a -> b
$! Text -> Value -> HashMap Text Value -> HashMap Text Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert (Text -> Text -> Text
T.append Text
pfx Text
name) Value
value HashMap Text Value
m
  directive Text
pfx Text
f HashMap Text Value
m (Group Text
name [Directive]
xs) = (HashMap Text Value -> Directive -> IO (HashMap Text Value))
-> HashMap Text Value -> [Directive] -> IO (HashMap Text Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Text
-> Text
-> HashMap Text Value
-> Directive
-> IO (HashMap Text Value)
directive Text
pfx' Text
f) HashMap Text Value
m [Directive]
xs
      where pfx' :: Text
pfx' = [Text] -> Text
T.concat [Text
pfx, Text
name, Text
"."]
  directive Text
pfx Text
f HashMap Text Value
m (Import Text
path) =
      let f' :: Text
f' = Text -> Text -> Text
relativize Text
f Text
path
      in  case Worth Text -> HashMap (Worth Text) [Directive] -> Maybe [Directive]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (Text -> Worth Text
forall {b}. b -> Worth b
Required (Text -> Text -> Text
relativize Text
f Text
path)) HashMap (Worth Text) [Directive]
files of
            Just [Directive]
ds -> (HashMap Text Value -> Directive -> IO (HashMap Text Value))
-> HashMap Text Value -> [Directive] -> IO (HashMap Text Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Text
-> Text
-> HashMap Text Value
-> Directive
-> IO (HashMap Text Value)
directive Text
pfx Text
f') HashMap Text Value
m [Directive]
ds
            Maybe [Directive]
_       -> HashMap Text Value -> IO (HashMap Text Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HashMap Text Value
m

interpolate :: T.Text -> T.Text -> H.HashMap Name Value -> IO T.Text
interpolate :: Text -> Text -> HashMap Text Value -> IO Text
interpolate Text
pfx Text
s HashMap Text Value
env
    | Text
"$" Text -> Text -> Bool
`T.isInfixOf` Text
s =
      case Parser [Interpolate] -> Text -> Either String [Interpolate]
forall a. Parser a -> Text -> Either String a
T.parseOnly Parser [Interpolate]
interp Text
s of
        Left String
err   -> ConfigError -> IO Text
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ConfigError -> IO Text) -> ConfigError -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> String -> ConfigError
ParseError String
"" String
err
        Right [Interpolate]
xs -> (LazyText -> Text
L.toStrict (LazyText -> Text) -> ([Builder] -> LazyText) -> [Builder] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
toLazyText (Builder -> LazyText)
-> ([Builder] -> Builder) -> [Builder] -> LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat) ([Builder] -> Text) -> IO [Builder] -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Interpolate -> IO Builder) -> [Interpolate] -> IO [Builder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Interpolate -> IO Builder
interpret [Interpolate]
xs
    | Bool
otherwise = Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
 where
  lookupEnv :: Text -> Maybe Value
lookupEnv Text
name = [Maybe Value] -> Maybe Value
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Value] -> Maybe Value) -> [Maybe Value] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe Value) -> [Text] -> [Maybe Value]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> HashMap Text Value -> Maybe Value)
-> HashMap Text Value -> Text -> Maybe Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup HashMap Text Value
env) [Text]
fullnames
    where fullnames :: [Text]
fullnames = ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Text] -> Text
T.intercalate Text
".")     -- ["a.b.c.x","a.b.x","a.x","x"]
                    ([[Text]] -> [Text]) -> (Text -> [[Text]]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
nameText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)) -- [["a","b","c","x"],["a","b","x"],["a","x"],["x"]]
                    ([[Text]] -> [[Text]]) -> (Text -> [[Text]]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [[Text]]
forall a. [a] -> [[a]]
tails                   -- [["c","b","a"],["b","a"],["a"],[]]
                    ([Text] -> [[Text]]) -> (Text -> [Text]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse                 -- ["c","b","a"]
                    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)   -- ["a","b","c"]
                    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.')         -- ["a","b","c",""]
                    (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
pfx                     -- "a.b.c."

  interpret :: Interpolate -> IO Builder
interpret (Literal Text
x)   = Builder -> IO Builder
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Builder
fromText Text
x)
  interpret (Interpolate Text
name) =
      case Text -> Maybe Value
lookupEnv Text
name of
        Just (String Text
x) -> Builder -> IO Builder
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Builder
fromText Text
x)
        Just (Number Rational
r)
            | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 -> Builder -> IO Builder
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Builder
forall a. Integral a => a -> Builder
decimal (Integer -> Builder) -> Integer -> Builder
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r)
            | Bool
otherwise -> Builder -> IO Builder
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$ Double -> Builder
forall a. RealFloat a => a -> Builder
realFloat (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r :: Double)
                           -- TODO: Use a dedicated Builder for Rationals instead of
                           -- using realFloat on a Double.
        Just Value
_          -> String -> IO Builder
forall a. HasCallStack => String -> a
error String
"type error"
        Maybe Value
_ -> do
          e <- IO String -> IO (Either SomeException String)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO String -> IO (Either SomeException String))
-> (Text -> IO String) -> Text -> IO (Either SomeException String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
getEnv (String -> IO String) -> (Text -> String) -> Text -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> IO (Either SomeException String))
-> Text -> IO (Either SomeException String)
forall a b. (a -> b) -> a -> b
$ Text
name
          case e of
            Left (SomeException
_::SomeException) ->
                ConfigError -> IO Builder
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ConfigError -> IO Builder)
-> (String -> ConfigError) -> String -> IO Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ConfigError
ParseError String
"" (String -> IO Builder) -> String -> IO Builder
forall a b. (a -> b) -> a -> b
$ String
"no such variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
name
            Right String
x -> Builder -> IO Builder
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Builder
fromString String
x)

importsOf :: Path -> [Directive] -> [Worth Path]
importsOf :: Text -> [Directive] -> [Worth Text]
importsOf Text
path (Import Text
ref : [Directive]
xs) = Text -> Worth Text
forall {b}. b -> Worth b
Required (Text -> Text -> Text
relativize Text
path Text
ref)
                                 Worth Text -> [Worth Text] -> [Worth Text]
forall a. a -> [a] -> [a]
: Text -> [Directive] -> [Worth Text]
importsOf Text
path [Directive]
xs
importsOf Text
path (Group Text
_ [Directive]
ys : [Directive]
xs) = Text -> [Directive] -> [Worth Text]
importsOf Text
path [Directive]
ys [Worth Text] -> [Worth Text] -> [Worth Text]
forall a. [a] -> [a] -> [a]
++ Text -> [Directive] -> [Worth Text]
importsOf Text
path [Directive]
xs
importsOf Text
path (Directive
_ : [Directive]
xs)          = Text -> [Directive] -> [Worth Text]
importsOf Text
path [Directive]
xs
importsOf Text
_    [Directive]
_                 = []

relativize :: Path -> Path -> Path
relativize :: Text -> Text -> Text
relativize Text
parent Text
child
  | HasCallStack => Text -> Char
Text -> Char
T.head Text
child Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = Text
child
  | Bool
otherwise           = (Text, Text) -> Text
forall a b. (a, b) -> a
fst (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"/" Text
parent) Text -> Text -> Text
`T.append` Text
child

loadOne :: Worth FilePath -> IO [Directive]
loadOne :: Worth String -> IO [Directive]
loadOne Worth String
path = do
  es <- IO LazyText -> IO (Either SomeException LazyText)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO LazyText -> IO (Either SomeException LazyText))
-> (Worth String -> IO LazyText)
-> Worth String
-> IO (Either SomeException LazyText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO LazyText
L.readFile (String -> IO LazyText)
-> (Worth String -> String) -> Worth String -> IO LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Worth String -> String
forall a. Worth a -> a
worth (Worth String -> IO (Either SomeException LazyText))
-> Worth String -> IO (Either SomeException LazyText)
forall a b. (a -> b) -> a -> b
$ Worth String
path
  case es of
    Left (SomeException
err::SomeException) -> case Worth String
path of
                                   Required String
_ -> SomeException -> IO [Directive]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
err
                                   Worth String
_          -> [Directive] -> IO [Directive]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Right LazyText
s -> do
            p <- Either String [Directive] -> IO (Either String [Directive])
forall a. a -> IO a
evaluate (Result [Directive] -> Either String [Directive]
forall r. Result r -> Either String r
L.eitherResult (Result [Directive] -> Either String [Directive])
-> Result [Directive] -> Either String [Directive]
forall a b. (a -> b) -> a -> b
$ Parser [Directive] -> LazyText -> Result [Directive]
forall a. Parser a -> LazyText -> Result a
L.parse Parser [Directive]
topLevel LazyText
s)
                 IO (Either String [Directive])
-> (ConfigError -> IO (Either String [Directive]))
-> IO (Either String [Directive])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(ConfigError
e::ConfigError) ->
                 ConfigError -> IO (Either String [Directive])
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ConfigError -> IO (Either String [Directive]))
-> ConfigError -> IO (Either String [Directive])
forall a b. (a -> b) -> a -> b
$ case ConfigError
e of
                             ParseError String
_ String
err -> String -> String -> ConfigError
ParseError (Worth String -> String
forall a. Worth a -> a
worth Worth String
path) String
err
            case p of
              Left String
err -> ConfigError -> IO [Directive]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> String -> ConfigError
ParseError (Worth String -> String
forall a. Worth a -> a
worth Worth String
path) String
err)
              Right [Directive]
ds -> [Directive] -> IO [Directive]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Directive]
ds

-- | Subscribe for notifications.  The given action will be invoked
-- when any change occurs to a configuration property matching the
-- supplied pattern.
subscribe :: Config -> Pattern -> ChangeHandler -> IO ()
subscribe :: Config -> Pattern -> ChangeHandler -> IO ()
subscribe (Config Text
root BaseConfig{Maybe AutoConfig
IORef [(Text, Worth Text)]
IORef (HashMap Text Value)
IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: BaseConfig -> Maybe AutoConfig
cfgPaths :: BaseConfig -> IORef [(Text, Worth Text)]
cfgMap :: BaseConfig -> IORef (HashMap Text Value)
cfgSubs :: BaseConfig -> IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: Maybe AutoConfig
cfgPaths :: IORef [(Text, Worth Text)]
cfgMap :: IORef (HashMap Text Value)
cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
..}) Pattern
pat ChangeHandler
act = do
  m' <- IORef (HashMap Pattern [ChangeHandler])
-> (HashMap Pattern [ChangeHandler]
    -> (HashMap Pattern [ChangeHandler],
        HashMap Pattern [ChangeHandler]))
-> IO (HashMap Pattern [ChangeHandler])
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap Pattern [ChangeHandler])
cfgSubs ((HashMap Pattern [ChangeHandler]
  -> (HashMap Pattern [ChangeHandler],
      HashMap Pattern [ChangeHandler]))
 -> IO (HashMap Pattern [ChangeHandler]))
-> (HashMap Pattern [ChangeHandler]
    -> (HashMap Pattern [ChangeHandler],
        HashMap Pattern [ChangeHandler]))
-> IO (HashMap Pattern [ChangeHandler])
forall a b. (a -> b) -> a -> b
$ \HashMap Pattern [ChangeHandler]
m ->
        let m' :: HashMap Pattern [ChangeHandler]
m' = ([ChangeHandler] -> [ChangeHandler] -> [ChangeHandler])
-> Pattern
-> [ChangeHandler]
-> HashMap Pattern [ChangeHandler]
-> HashMap Pattern [ChangeHandler]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
H.insertWith [ChangeHandler] -> [ChangeHandler] -> [ChangeHandler]
forall a. [a] -> [a] -> [a]
(++) (Text -> Pattern -> Pattern
localPattern Text
root Pattern
pat) [ChangeHandler
act] HashMap Pattern [ChangeHandler]
m in (HashMap Pattern [ChangeHandler]
m', HashMap Pattern [ChangeHandler]
m')
  evaluate m' >> return ()

localPattern :: Name -> Pattern -> Pattern
localPattern :: Text -> Pattern -> Pattern
localPattern Text
pfx (Exact  Text
s) = Text -> Pattern
Exact  (Text
pfx Text -> Text -> Text
`T.append` Text
s)
localPattern Text
pfx (Prefix Text
s) = Text -> Pattern
Prefix (Text
pfx Text -> Text -> Text
`T.append` Text
s)

notifySubscribers :: BaseConfig -> H.HashMap Name Value -> H.HashMap Name Value
                  -> H.HashMap Pattern [ChangeHandler] -> IO ()
notifySubscribers :: BaseConfig
-> HashMap Text Value
-> HashMap Text Value
-> HashMap Pattern [ChangeHandler]
-> IO ()
notifySubscribers BaseConfig{Maybe AutoConfig
IORef [(Text, Worth Text)]
IORef (HashMap Text Value)
IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: BaseConfig -> Maybe AutoConfig
cfgPaths :: BaseConfig -> IORef [(Text, Worth Text)]
cfgMap :: BaseConfig -> IORef (HashMap Text Value)
cfgSubs :: BaseConfig -> IORef (HashMap Pattern [ChangeHandler])
cfgAuto :: Maybe AutoConfig
cfgPaths :: IORef [(Text, Worth Text)]
cfgMap :: IORef (HashMap Text Value)
cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
..} HashMap Text Value
m HashMap Text Value
m' HashMap Pattern [ChangeHandler]
subs = (Pattern -> [ChangeHandler] -> IO () -> IO ())
-> IO () -> HashMap Pattern [ChangeHandler] -> IO ()
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
H.foldrWithKey Pattern -> [ChangeHandler] -> IO () -> IO ()
forall {t :: * -> *} {b}.
Foldable t =>
Pattern -> t ChangeHandler -> IO b -> IO b
go (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) HashMap Pattern [ChangeHandler]
subs
 where
  changedOrGone :: [(Text, Maybe Value)]
changedOrGone = (Text -> Value -> [(Text, Maybe Value)] -> [(Text, Maybe Value)])
-> [(Text, Maybe Value)]
-> HashMap Text Value
-> [(Text, Maybe Value)]
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
H.foldrWithKey Text -> Value -> [(Text, Maybe Value)] -> [(Text, Maybe Value)]
check [] HashMap Text Value
m
      where check :: Text -> Value -> [(Text, Maybe Value)] -> [(Text, Maybe Value)]
check Text
n Value
v [(Text, Maybe Value)]
nvs = case Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
n HashMap Text Value
m' of
                              Just Value
v' | Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
v'   -> (Text
n,Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v')(Text, Maybe Value)
-> [(Text, Maybe Value)] -> [(Text, Maybe Value)]
forall a. a -> [a] -> [a]
:[(Text, Maybe Value)]
nvs
                                      | Bool
otherwise -> [(Text, Maybe Value)]
nvs
                              Maybe Value
_                   -> (Text
n,Maybe Value
forall a. Maybe a
Nothing)(Text, Maybe Value)
-> [(Text, Maybe Value)] -> [(Text, Maybe Value)]
forall a. a -> [a] -> [a]
:[(Text, Maybe Value)]
nvs
  new :: [(Text, Value)]
new = (Text -> Value -> [(Text, Value)] -> [(Text, Value)])
-> [(Text, Value)] -> HashMap Text Value -> [(Text, Value)]
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
H.foldrWithKey Text -> Value -> [(Text, Value)] -> [(Text, Value)]
forall {b}. Text -> b -> [(Text, b)] -> [(Text, b)]
check [] HashMap Text Value
m'
      where check :: Text -> b -> [(Text, b)] -> [(Text, b)]
check Text
n b
v [(Text, b)]
nvs = case Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
n HashMap Text Value
m of
                              Maybe Value
Nothing -> (Text
n,b
v)(Text, b) -> [(Text, b)] -> [(Text, b)]
forall a. a -> [a] -> [a]
:[(Text, b)]
nvs
                              Maybe Value
_       -> [(Text, b)]
nvs
  notify :: p -> t -> t -> (t -> t -> IO ()) -> IO ()
notify p
p t
n t
v t -> t -> IO ()
a = t -> t -> IO ()
a t
n t
v IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (SomeException -> IO ())
-> (AutoConfig -> SomeException -> IO ())
-> Maybe AutoConfig
-> SomeException
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SomeException -> IO ()
forall a. Show a => a -> IO ()
report AutoConfig -> SomeException -> IO ()
onError Maybe AutoConfig
cfgAuto
    where report :: a -> IO ()
report a
e = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                     String
"*** a ChangeHandler threw an exception for " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     (p, t) -> String
forall a. Show a => a -> String
show (p
p,t
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
e
  go :: Pattern -> t ChangeHandler -> IO b -> IO b
go p :: Pattern
p@(Exact Text
n) t ChangeHandler
acts IO b
next = (IO b -> () -> IO b
forall a b. a -> b -> a
const IO b
next (() -> IO b) -> IO () -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
    let v' :: Maybe Value
v' = Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
n HashMap Text Value
m'
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
n HashMap Text Value
m Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Value
v') (IO () -> IO ())
-> (t ChangeHandler -> IO ()) -> t ChangeHandler -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChangeHandler -> IO ()) -> t ChangeHandler -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern -> Text -> Maybe Value -> ChangeHandler -> IO ()
forall {p} {t} {t}.
(Show p, Show t) =>
p -> t -> t -> (t -> t -> IO ()) -> IO ()
notify Pattern
p Text
n Maybe Value
v') (t ChangeHandler -> IO ()) -> t ChangeHandler -> IO ()
forall a b. (a -> b) -> a -> b
$ t ChangeHandler
acts
  go p :: Pattern
p@(Prefix Text
n) t ChangeHandler
acts IO b
next = (IO b -> () -> IO b
forall a b. a -> b -> a
const IO b
next (() -> IO b) -> IO () -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
    let matching :: [(Text, b)] -> [(Text, b)]
matching = ((Text, b) -> Bool) -> [(Text, b)] -> [(Text, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
T.isPrefixOf Text
n (Text -> Bool) -> ((Text, b) -> Text) -> (Text, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, b) -> Text
forall a b. (a, b) -> a
fst)
    [(Text, Value)] -> ((Text, Value) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Text, Value)] -> [(Text, Value)]
forall {b}. [(Text, b)] -> [(Text, b)]
matching [(Text, Value)]
new) (((Text, Value) -> IO ()) -> IO ())
-> ((Text, Value) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Text
n',Value
v) -> (ChangeHandler -> IO ()) -> t ChangeHandler -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern -> Text -> Maybe Value -> ChangeHandler -> IO ()
forall {p} {t} {t}.
(Show p, Show t) =>
p -> t -> t -> (t -> t -> IO ()) -> IO ()
notify Pattern
p Text
n' (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v)) t ChangeHandler
acts
    [(Text, Maybe Value)] -> ((Text, Maybe Value) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Text, Maybe Value)] -> [(Text, Maybe Value)]
forall {b}. [(Text, b)] -> [(Text, b)]
matching [(Text, Maybe Value)]
changedOrGone) (((Text, Maybe Value) -> IO ()) -> IO ())
-> ((Text, Maybe Value) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Text
n',Maybe Value
v) -> (ChangeHandler -> IO ()) -> t ChangeHandler -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern -> Text -> Maybe Value -> ChangeHandler -> IO ()
forall {p} {t} {t}.
(Show p, Show t) =>
p -> t -> t -> (t -> t -> IO ()) -> IO ()
notify Pattern
p Text
n' Maybe Value
v) t ChangeHandler
acts

-- | A completely empty configuration.
empty :: Config
empty :: Config
empty = Text -> BaseConfig -> Config
Config Text
"" (BaseConfig -> Config) -> BaseConfig -> Config
forall a b. (a -> b) -> a -> b
$ IO BaseConfig -> BaseConfig
forall a. IO a -> a
unsafePerformIO (IO BaseConfig -> BaseConfig) -> IO BaseConfig -> BaseConfig
forall a b. (a -> b) -> a -> b
$ do
          p <- [(Text, Worth Text)] -> IO (IORef [(Text, Worth Text)])
forall a. a -> IO (IORef a)
newIORef []
          m <- newIORef H.empty
          s <- newIORef H.empty
          return BaseConfig {
                       cfgAuto = Nothing
                     , cfgPaths = p
                     , cfgMap = m
                     , cfgSubs = s
                     }
{-# NOINLINE empty #-}

-- $format
--
-- A configuration file consists of a series of directives and
-- comments, encoded in UTF-8.  A comment begins with a \"@#@\"
-- character, and continues to the end of a line.
--
-- Files and directives are processed from first to last, top to
-- bottom.

-- $binding
--
-- A binding associates a name with a value.
--
-- > my_string = "hi mom! \u2603"
-- > your-int-33 = 33
-- > his_bool = on
-- > HerList = [1, "foo", off]
--
-- A name must begin with a Unicode letter, which is followed by zero
-- or more of a Unicode alphanumeric code point, hyphen \"@-@\", or
-- underscore \"@_@\".
--
-- Bindings are created or overwritten in the order in which they are
-- encountered.  It is legitimate for a name to be bound multiple
-- times, in which case the last value wins.
--
-- > a = 1
-- > a = true
-- > # value of a is now true, not 1

-- $types
--
-- The configuration file format supports the following data types:
--
-- * Booleans, represented as @on@ or @off@, @true@ or @false@.  These
--   are case sensitive, so do not try to use @True@ instead of
--   @true@!
--
-- * Integers, represented in base 10.
--
-- * Unicode strings, represented as text (possibly containing escape
--   sequences) surrounded by double quotes.
--
-- * Heterogeneous lists of values, represented as an opening square
--   bracket \"@[@\", followed by a series of comma-separated values,
--   ending with a closing square bracket \"@]@\".
--
-- The following escape sequences are recognised in a text string:
--
-- * @\\n@ - newline
--
-- * @\\r@ - carriage return
--
-- * @\\t@ - horizontal tab
--
-- * @\\\\@ - backslash
--
-- * @\\\"@ - double quote
--
-- * @\\u@/xxxx/ - Unicode character from the basic multilingual
--   plane, encoded as four hexadecimal digits
--
-- * @\\u@/xxxx/@\\u@/xxxx/ - Unicode character from an astral plane,
--   as two hexadecimal-encoded UTF-16 surrogates

-- $interp
--
-- Strings support interpolation, so that you can dynamically
-- construct a string based on data in your configuration or the OS
-- environment.
--
-- If a string value contains the special sequence \"@$(foo)@\" (for
-- any name @foo@), then the name @foo@ will be looked up in the
-- configuration data and its value substituted.  If that name cannot
-- be found, it will be looked up in the OS environment.
--
-- For security reasons, it is an error for a string interpolation
-- fragment to contain a name that cannot be found in either the
-- current configuration or the environment.
--
-- To represent a single literal \"@$@\" character in a string, double
-- it: \"@$$@\".

-- $group
--
-- It is possible to group a number of directives together under a
-- single prefix:
--
-- > my-group
-- > {
-- >   a = 1
-- >
-- >   # groups support nesting
-- >   nested {
-- >     b = "yay!"
-- >   }
-- > }
--
-- The name of a group is used as a prefix for the items in the
-- group. For instance, the value of \"@a@\" above can be retrieved
-- using 'lookup' by supplying the name \"@my-group.a@\", and \"@b@\"
-- will be named \"@my-group.nested.b@\".

-- $import
--
-- To import the contents of another configuration file, use the
-- @import@ directive.
--
-- > import "$(HOME)/etc/myapp.cfg"
--
-- Absolute paths are imported as is.  Relative paths are resolved with
-- respect to the file they are imported from.  It is an error for an
-- @import@ directive to name a file that does not exist, cannot be read,
-- or contains errors.
--
-- If an @import@ appears inside a group, the group's naming prefix
-- will be applied to all of the names imported from the given
-- configuration file.
--
-- Supposing we have a file named \"@foo.cfg@\":
--
-- > bar = 1
--
-- And another file that imports it into a group:
--
-- > hi {
-- >   import "foo.cfg"
-- > }
--
-- This will result in a value named \"@hi.bar@\".

-- $notify
--
-- To more efficiently support an application's need to dynamically
-- reconfigure, a subsystem may ask to be notified when a
-- configuration property is changed as a result of a reload, using
-- the 'subscribe' action.