{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards,
ScopedTypeVariables, TupleSections #-}
module Data.Configurator
(
Worth(..)
, autoReload
, autoReloadGroups
, autoConfig
, empty
, lookup
, lookupDefault
, require
, prefix
, exact
, subscribe
, load
, loadGroups
, reload
, subconfig
, addToConfig
, addGroupsToConfig
, 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 Path] -> IO (HashMap (Worth Path) [Directive])
loadFiles = (HashMap (Worth Path) [Directive]
-> Worth Path -> IO (HashMap (Worth Path) [Directive]))
-> HashMap (Worth Path) [Directive]
-> [Worth Path]
-> IO (HashMap (Worth Path) [Directive])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HashMap (Worth Path) [Directive]
-> Worth Path -> IO (HashMap (Worth Path) [Directive])
go HashMap (Worth Path) [Directive]
forall k v. HashMap k v
H.empty
where
go :: HashMap (Worth Path) [Directive]
-> Worth Path -> IO (HashMap (Worth Path) [Directive])
go seen :: HashMap (Worth Path) [Directive]
seen path :: Worth Path
path = do
let rewrap :: b -> Worth b
rewrap n :: b
n = b -> Path -> b
forall a b. a -> b -> a
const b
n (Path -> b) -> Worth Path -> Worth b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Worth Path
path
wpath :: Path
wpath = Worth Path -> Path
forall a. Worth a -> a
worth Worth Path
path
Worth Path
path' <- Path -> Worth Path
forall b. b -> Worth b
rewrap (Path -> Worth Path) -> IO Path -> IO (Worth Path)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> Path -> HashMap Path Value -> IO Path
interpolate "" Path
wpath HashMap Path Value
forall k v. HashMap k v
H.empty
[Directive]
ds <- Worth FilePath -> IO [Directive]
loadOne (Path -> FilePath
T.unpack (Path -> FilePath) -> Worth Path -> Worth FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Worth Path
path')
let !seen' :: HashMap (Worth Path) [Directive]
seen' = Worth Path
-> [Directive]
-> HashMap (Worth Path) [Directive]
-> HashMap (Worth Path) [Directive]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Worth Path
path [Directive]
ds HashMap (Worth Path) [Directive]
seen
notSeen :: Worth Path -> Bool
notSeen n :: Worth Path
n = Bool -> Bool
not (Bool -> Bool)
-> (HashMap (Worth Path) [Directive] -> Bool)
-> HashMap (Worth Path) [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 Path) [Directive] -> Maybe [Directive])
-> HashMap (Worth Path) [Directive]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Worth Path -> HashMap (Worth Path) [Directive] -> Maybe [Directive]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Worth Path
n (HashMap (Worth Path) [Directive] -> Bool)
-> HashMap (Worth Path) [Directive] -> Bool
forall a b. (a -> b) -> a -> b
$ HashMap (Worth Path) [Directive]
seen
(HashMap (Worth Path) [Directive]
-> Worth Path -> IO (HashMap (Worth Path) [Directive]))
-> HashMap (Worth Path) [Directive]
-> [Worth Path]
-> IO (HashMap (Worth Path) [Directive])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HashMap (Worth Path) [Directive]
-> Worth Path -> IO (HashMap (Worth Path) [Directive])
go HashMap (Worth Path) [Directive]
seen' ([Worth Path] -> IO (HashMap (Worth Path) [Directive]))
-> ([Directive] -> [Worth Path])
-> [Directive]
-> IO (HashMap (Worth Path) [Directive])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Worth Path -> Bool) -> [Worth Path] -> [Worth Path]
forall a. (a -> Bool) -> [a] -> [a]
filter Worth Path -> Bool
notSeen ([Worth Path] -> [Worth Path])
-> ([Directive] -> [Worth Path]) -> [Directive] -> [Worth Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [Directive] -> [Worth Path]
importsOf Path
wpath ([Directive] -> IO (HashMap (Worth Path) [Directive]))
-> [Directive] -> IO (HashMap (Worth Path) [Directive])
forall a b. (a -> b) -> a -> b
$ [Directive]
ds
load :: [Worth FilePath] -> IO Config
load :: [Worth FilePath] -> IO Config
load files :: [Worth FilePath]
files = (BaseConfig -> Config) -> IO BaseConfig -> IO Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path -> BaseConfig -> Config
Config "") (IO BaseConfig -> IO Config) -> IO BaseConfig -> IO Config
forall a b. (a -> b) -> a -> b
$ Maybe AutoConfig -> [(Path, Worth FilePath)] -> IO BaseConfig
load' Maybe AutoConfig
forall a. Maybe a
Nothing ((Worth FilePath -> (Path, Worth FilePath))
-> [Worth FilePath] -> [(Path, Worth FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\f :: Worth FilePath
f -> ("", Worth FilePath
f)) [Worth FilePath]
files)
loadGroups :: [(Name, Worth FilePath)] -> IO Config
loadGroups :: [(Path, Worth FilePath)] -> IO Config
loadGroups files :: [(Path, Worth FilePath)]
files = (BaseConfig -> Config) -> IO BaseConfig -> IO Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path -> BaseConfig -> Config
Config "") (IO BaseConfig -> IO Config) -> IO BaseConfig -> IO Config
forall a b. (a -> b) -> a -> b
$ Maybe AutoConfig -> [(Path, Worth FilePath)] -> IO BaseConfig
load' Maybe AutoConfig
forall a. Maybe a
Nothing [(Path, Worth FilePath)]
files
load' :: Maybe AutoConfig -> [(Name, Worth FilePath)] -> IO BaseConfig
load' :: Maybe AutoConfig -> [(Path, Worth FilePath)] -> IO BaseConfig
load' auto :: Maybe AutoConfig
auto paths0 :: [(Path, Worth FilePath)]
paths0 = do
let second :: (t -> b) -> (a, t) -> (a, b)
second f :: t -> b
f (x :: a
x,y :: t
y) = (a
x, t -> b
f t
y)
paths :: [(Path, Worth Path)]
paths = ((Path, Worth FilePath) -> (Path, Worth Path))
-> [(Path, Worth FilePath)] -> [(Path, Worth Path)]
forall a b. (a -> b) -> [a] -> [b]
map ((Worth FilePath -> Worth Path)
-> (Path, Worth FilePath) -> (Path, Worth Path)
forall t b a. (t -> b) -> (a, t) -> (a, b)
second ((FilePath -> Path) -> Worth FilePath -> Worth Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Path
T.pack)) [(Path, Worth FilePath)]
paths0
HashMap (Worth Path) [Directive]
ds <- [Worth Path] -> IO (HashMap (Worth Path) [Directive])
loadFiles (((Path, Worth Path) -> Worth Path)
-> [(Path, Worth Path)] -> [Worth Path]
forall a b. (a -> b) -> [a] -> [b]
map (Path, Worth Path) -> Worth Path
forall a b. (a, b) -> b
snd [(Path, Worth Path)]
paths)
IORef [(Path, Worth Path)]
p <- [(Path, Worth Path)] -> IO (IORef [(Path, Worth Path)])
forall a. a -> IO (IORef a)
newIORef [(Path, Worth Path)]
paths
IORef (HashMap Path Value)
m <- HashMap Path Value -> IO (IORef (HashMap Path Value))
forall a. a -> IO (IORef a)
newIORef (HashMap Path Value -> IO (IORef (HashMap Path Value)))
-> IO (HashMap Path Value) -> IO (IORef (HashMap Path Value))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Path, Worth Path)]
-> HashMap (Worth Path) [Directive] -> IO (HashMap Path Value)
flatten [(Path, Worth Path)]
paths HashMap (Worth Path) [Directive]
ds
IORef (HashMap Pattern [ChangeHandler])
s <- HashMap Pattern [ChangeHandler]
-> IO (IORef (HashMap Pattern [ChangeHandler]))
forall a. a -> IO (IORef a)
newIORef HashMap Pattern [ChangeHandler]
forall k v. HashMap k v
H.empty
BaseConfig -> IO BaseConfig
forall (m :: * -> *) a. Monad m => a -> m a
return BaseConfig :: Maybe AutoConfig
-> IORef [(Path, Worth Path)]
-> IORef (HashMap Path Value)
-> IORef (HashMap Pattern [ChangeHandler])
-> BaseConfig
BaseConfig {
cfgAuto :: Maybe AutoConfig
cfgAuto = Maybe AutoConfig
auto
, cfgPaths :: IORef [(Path, Worth Path)]
cfgPaths = IORef [(Path, Worth Path)]
p
, cfgMap :: IORef (HashMap Path Value)
cfgMap = IORef (HashMap Path Value)
m
, cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
cfgSubs = IORef (HashMap Pattern [ChangeHandler])
s
}
subconfig :: Name -> Config -> Config
subconfig :: Path -> Config -> Config
subconfig g :: Path
g (Config root :: Path
root cfg :: BaseConfig
cfg) = Path -> BaseConfig -> Config
Config ([Path] -> Path
T.concat [Path
root, Path
g, "."]) BaseConfig
cfg
reload :: Config -> IO ()
reload :: Config -> IO ()
reload (Config _ cfg :: BaseConfig
cfg@BaseConfig{..}) = BaseConfig -> IO ()
reloadBase BaseConfig
cfg
reloadBase :: BaseConfig -> IO ()
reloadBase :: BaseConfig -> IO ()
reloadBase cfg :: BaseConfig
cfg@BaseConfig{..} = do
[(Path, Worth Path)]
paths <- IORef [(Path, Worth Path)] -> IO [(Path, Worth Path)]
forall a. IORef a -> IO a
readIORef IORef [(Path, Worth Path)]
cfgPaths
HashMap Path Value
m' <- [(Path, Worth Path)]
-> HashMap (Worth Path) [Directive] -> IO (HashMap Path Value)
flatten [(Path, Worth Path)]
paths (HashMap (Worth Path) [Directive] -> IO (HashMap Path Value))
-> IO (HashMap (Worth Path) [Directive]) -> IO (HashMap Path Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Worth Path] -> IO (HashMap (Worth Path) [Directive])
loadFiles (((Path, Worth Path) -> Worth Path)
-> [(Path, Worth Path)] -> [Worth Path]
forall a b. (a -> b) -> [a] -> [b]
map (Path, Worth Path) -> Worth Path
forall a b. (a, b) -> b
snd [(Path, Worth Path)]
paths)
HashMap Path Value
m <- IORef (HashMap Path Value)
-> (HashMap Path Value -> (HashMap Path Value, HashMap Path Value))
-> IO (HashMap Path Value)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap Path Value)
cfgMap ((HashMap Path Value -> (HashMap Path Value, HashMap Path Value))
-> IO (HashMap Path Value))
-> (HashMap Path Value -> (HashMap Path Value, HashMap Path Value))
-> IO (HashMap Path Value)
forall a b. (a -> b) -> a -> b
$ \m :: HashMap Path Value
m -> (HashMap Path Value
m', HashMap Path Value
m)
BaseConfig
-> HashMap Path Value
-> HashMap Path Value
-> HashMap Pattern [ChangeHandler]
-> IO ()
notifySubscribers BaseConfig
cfg HashMap Path Value
m HashMap Path Value
m' (HashMap Pattern [ChangeHandler] -> IO ())
-> IO (HashMap Pattern [ChangeHandler]) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (HashMap Pattern [ChangeHandler])
-> IO (HashMap Pattern [ChangeHandler])
forall a. IORef a -> IO a
readIORef IORef (HashMap Pattern [ChangeHandler])
cfgSubs
addToConfig :: [Worth FilePath] -> Config -> IO ()
addToConfig :: [Worth FilePath] -> Config -> IO ()
addToConfig paths0 :: [Worth FilePath]
paths0 cfg :: Config
cfg = [(Path, Worth FilePath)] -> Config -> IO ()
addGroupsToConfig ((Worth FilePath -> (Path, Worth FilePath))
-> [Worth FilePath] -> [(Path, Worth FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Worth FilePath
x -> ("",Worth FilePath
x)) [Worth FilePath]
paths0) Config
cfg
addGroupsToConfig :: [(Name, Worth FilePath)] -> Config -> IO ()
addGroupsToConfig :: [(Path, Worth FilePath)] -> Config -> IO ()
addGroupsToConfig paths0 :: [(Path, Worth FilePath)]
paths0 (Config root :: Path
root cfg :: BaseConfig
cfg@BaseConfig{..}) = do
let fix :: (Path, f FilePath) -> (Path, f Path)
fix (x :: Path
x,y :: f FilePath
y) = (Path
root Path -> Path -> Path
`T.append` Path
x, (FilePath -> Path) -> f FilePath -> f Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Path
T.pack f FilePath
y)
paths :: [(Path, Worth Path)]
paths = ((Path, Worth FilePath) -> (Path, Worth Path))
-> [(Path, Worth FilePath)] -> [(Path, Worth Path)]
forall a b. (a -> b) -> [a] -> [b]
map (Path, Worth FilePath) -> (Path, Worth Path)
forall (f :: * -> *).
Functor f =>
(Path, f FilePath) -> (Path, f Path)
fix [(Path, Worth FilePath)]
paths0
IORef [(Path, Worth Path)]
-> ([(Path, Worth Path)] -> ([(Path, Worth Path)], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [(Path, Worth Path)]
cfgPaths (([(Path, Worth Path)] -> ([(Path, Worth Path)], ())) -> IO ())
-> ([(Path, Worth Path)] -> ([(Path, Worth Path)], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \prev :: [(Path, Worth Path)]
prev -> ([(Path, Worth Path)]
prev [(Path, Worth Path)]
-> [(Path, Worth Path)] -> [(Path, Worth Path)]
forall a. [a] -> [a] -> [a]
++ [(Path, Worth Path)]
paths, ())
BaseConfig -> IO ()
reloadBase BaseConfig
cfg
autoConfig :: AutoConfig
autoConfig :: AutoConfig
autoConfig = AutoConfig :: Int -> (SomeException -> IO ()) -> AutoConfig
AutoConfig {
interval :: Int
interval = 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 (m :: * -> *) a. Monad m => a -> m a
return ()
}
autoReload :: AutoConfig
-> [Worth FilePath]
-> IO (Config, ThreadId)
autoReload :: AutoConfig -> [Worth FilePath] -> IO (Config, ThreadId)
autoReload auto :: AutoConfig
auto paths :: [Worth FilePath]
paths = AutoConfig -> [(Path, Worth FilePath)] -> IO (Config, ThreadId)
autoReloadGroups AutoConfig
auto ((Worth FilePath -> (Path, Worth FilePath))
-> [Worth FilePath] -> [(Path, Worth FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Worth FilePath
x -> ("", Worth FilePath
x)) [Worth FilePath]
paths)
autoReloadGroups :: AutoConfig
-> [(Name, Worth FilePath)]
-> IO (Config, ThreadId)
autoReloadGroups :: AutoConfig -> [(Path, Worth FilePath)] -> IO (Config, ThreadId)
autoReloadGroups AutoConfig{..} _
| Int
interval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 1 = FilePath -> IO (Config, ThreadId)
forall a. HasCallStack => FilePath -> a
error "autoReload: negative interval"
autoReloadGroups _ [] = FilePath -> IO (Config, ThreadId)
forall a. HasCallStack => FilePath -> a
error "autoReload: no paths to load"
autoReloadGroups auto :: AutoConfig
auto@AutoConfig{..} paths :: [(Path, Worth FilePath)]
paths = do
BaseConfig
cfg <- Maybe AutoConfig -> [(Path, Worth FilePath)] -> IO BaseConfig
load' (AutoConfig -> Maybe AutoConfig
forall a. a -> Maybe a
Just AutoConfig
auto) [(Path, Worth FilePath)]
paths
let files :: [Worth FilePath]
files = ((Path, Worth FilePath) -> Worth FilePath)
-> [(Path, Worth FilePath)] -> [Worth FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Path, Worth FilePath) -> Worth FilePath
forall a b. (a, b) -> b
snd [(Path, Worth FilePath)]
paths
loop :: [Maybe Meta] -> IO b
loop meta :: [Maybe Meta]
meta = do
Int -> IO ()
threadDelay (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
interval 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000000)
[Maybe Meta]
meta' <- [Worth FilePath] -> IO [Maybe Meta]
getMeta [Worth FilePath]
files
if [Maybe Meta]
meta' [Maybe Meta] -> [Maybe Meta] -> Bool
forall a. Eq a => a -> a -> Bool
== [Maybe Meta]
meta
then [Maybe Meta] -> IO b
loop [Maybe Meta]
meta
else (BaseConfig -> IO ()
reloadBase BaseConfig
cfg IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
onError) IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Maybe Meta] -> IO b
loop [Maybe Meta]
meta'
ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ [Maybe Meta] -> IO ()
forall b. [Maybe Meta] -> IO b
loop ([Maybe Meta] -> IO ()) -> IO [Maybe Meta] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Worth FilePath] -> IO [Maybe Meta]
getMeta [Worth FilePath]
files
(Config, ThreadId) -> IO (Config, ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path -> BaseConfig -> Config
Config "" BaseConfig
cfg, ThreadId
tid)
type Meta = (FileOffset, EpochTime)
getMeta :: [Worth FilePath] -> IO [Maybe Meta]
getMeta :: [Worth FilePath] -> IO [Maybe Meta]
getMeta paths :: [Worth FilePath]
paths = [Worth FilePath]
-> (Worth FilePath -> 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 FilePath]
paths ((Worth FilePath -> IO (Maybe Meta)) -> IO [Maybe Meta])
-> (Worth FilePath -> IO (Maybe Meta)) -> IO [Maybe Meta]
forall a b. (a -> b) -> a -> b
$ \path :: Worth FilePath
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 (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 (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
FileStatus
st <- FilePath -> IO FileStatus
getFileStatus (Worth FilePath -> FilePath
forall a. Worth a -> a
worth Worth FilePath
path)
Meta -> IO Meta
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> FileOffset
fileSize FileStatus
st, FileStatus -> EpochTime
modificationTime FileStatus
st)
lookup :: Configured a => Config -> Name -> IO (Maybe a)
lookup :: Config -> Path -> IO (Maybe a)
lookup (Config root :: Path
root BaseConfig{..}) name :: Path
name =
(Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a)
-> (HashMap Path Value -> Maybe (Maybe a))
-> HashMap Path Value
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Maybe a) -> Maybe Value -> Maybe (Maybe a)
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 Path Value -> Maybe Value)
-> HashMap Path Value
-> Maybe (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> HashMap Path Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (Path
root Path -> Path -> Path
`T.append` Path
name)) (HashMap Path Value -> Maybe a)
-> IO (HashMap Path Value) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (HashMap Path Value) -> IO (HashMap Path Value)
forall a. IORef a -> IO a
readIORef IORef (HashMap Path Value)
cfgMap
require :: Configured a => Config -> Name -> IO a
require :: Config -> Path -> IO a
require cfg :: Config
cfg name :: Path
name = do
Maybe a
val <- Config -> Path -> IO (Maybe a)
forall a. Configured a => Config -> Path -> IO (Maybe a)
lookup Config
cfg Path
name
case Maybe a
val of
Just v :: a
v -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
_ -> KeyError -> IO a
forall e a. Exception e => e -> IO a
throwIO (KeyError -> IO a) -> (Path -> KeyError) -> Path -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> KeyError
KeyError (Path -> IO a) -> Path -> IO a
forall a b. (a -> b) -> a -> b
$ Path
name
lookupDefault :: Configured a =>
a
-> Config -> Name -> IO a
lookupDefault :: a -> Config -> Path -> IO a
lookupDefault def :: a
def cfg :: Config
cfg name :: Path
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 -> Path -> IO (Maybe a)
forall a. Configured a => Config -> Path -> IO (Maybe a)
lookup Config
cfg Path
name
display :: Config -> IO ()
display :: Config -> IO ()
display (Config root :: Path
root BaseConfig{..}) = (Path, HashMap Path Value) -> IO ()
forall a. Show a => a -> IO ()
print ((Path, HashMap Path Value) -> IO ())
-> (HashMap Path Value -> (Path, HashMap Path Value))
-> HashMap Path Value
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path
root,) (HashMap Path Value -> IO ()) -> IO (HashMap Path Value) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (HashMap Path Value) -> IO (HashMap Path Value)
forall a. IORef a -> IO a
readIORef IORef (HashMap Path Value)
cfgMap
getMap :: Config -> IO (H.HashMap Name Value)
getMap :: Config -> IO (HashMap Path Value)
getMap = IORef (HashMap Path Value) -> IO (HashMap Path Value)
forall a. IORef a -> IO a
readIORef (IORef (HashMap Path Value) -> IO (HashMap Path Value))
-> (Config -> IORef (HashMap Path Value))
-> Config
-> IO (HashMap Path Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseConfig -> IORef (HashMap Path Value)
cfgMap (BaseConfig -> IORef (HashMap Path Value))
-> (Config -> BaseConfig) -> Config -> IORef (HashMap Path 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 :: [(Path, Worth Path)]
-> HashMap (Worth Path) [Directive] -> IO (HashMap Path Value)
flatten roots :: [(Path, Worth Path)]
roots files :: HashMap (Worth Path) [Directive]
files = (HashMap Path Value
-> (Path, Worth Path) -> IO (HashMap Path Value))
-> HashMap Path Value
-> [(Path, Worth Path)]
-> IO (HashMap Path Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HashMap Path Value -> (Path, Worth Path) -> IO (HashMap Path Value)
doPath HashMap Path Value
forall k v. HashMap k v
H.empty [(Path, Worth Path)]
roots
where
doPath :: HashMap Path Value -> (Path, Worth Path) -> IO (HashMap Path Value)
doPath m :: HashMap Path Value
m (pfx :: Path
pfx, f :: Worth Path
f) = case Worth Path -> HashMap (Worth Path) [Directive] -> Maybe [Directive]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Worth Path
f HashMap (Worth Path) [Directive]
files of
Nothing -> HashMap Path Value -> IO (HashMap Path Value)
forall (m :: * -> *) a. Monad m => a -> m a
return HashMap Path Value
m
Just ds :: [Directive]
ds -> (HashMap Path Value -> Directive -> IO (HashMap Path Value))
-> HashMap Path Value -> [Directive] -> IO (HashMap Path Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Path
-> Path
-> HashMap Path Value
-> Directive
-> IO (HashMap Path Value)
directive Path
pfx (Worth Path -> Path
forall a. Worth a -> a
worth Worth Path
f)) HashMap Path Value
m [Directive]
ds
directive :: Path
-> Path
-> HashMap Path Value
-> Directive
-> IO (HashMap Path Value)
directive pfx :: Path
pfx _ m :: HashMap Path Value
m (Bind name :: Path
name (String value :: Path
value)) = do
Path
v <- Path -> Path -> HashMap Path Value -> IO Path
interpolate Path
pfx Path
value HashMap Path Value
m
HashMap Path Value -> IO (HashMap Path Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap Path Value -> IO (HashMap Path Value))
-> HashMap Path Value -> IO (HashMap Path Value)
forall a b. (a -> b) -> a -> b
$! Path -> Value -> HashMap Path Value -> HashMap Path Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert (Path -> Path -> Path
T.append Path
pfx Path
name) (Path -> Value
String Path
v) HashMap Path Value
m
directive pfx :: Path
pfx _ m :: HashMap Path Value
m (Bind name :: Path
name value :: Value
value) =
HashMap Path Value -> IO (HashMap Path Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap Path Value -> IO (HashMap Path Value))
-> HashMap Path Value -> IO (HashMap Path Value)
forall a b. (a -> b) -> a -> b
$! Path -> Value -> HashMap Path Value -> HashMap Path Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert (Path -> Path -> Path
T.append Path
pfx Path
name) Value
value HashMap Path Value
m
directive pfx :: Path
pfx f :: Path
f m :: HashMap Path Value
m (Group name :: Path
name xs :: [Directive]
xs) = (HashMap Path Value -> Directive -> IO (HashMap Path Value))
-> HashMap Path Value -> [Directive] -> IO (HashMap Path Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Path
-> Path
-> HashMap Path Value
-> Directive
-> IO (HashMap Path Value)
directive Path
pfx' Path
f) HashMap Path Value
m [Directive]
xs
where pfx' :: Path
pfx' = [Path] -> Path
T.concat [Path
pfx, Path
name, "."]
directive pfx :: Path
pfx f :: Path
f m :: HashMap Path Value
m (Import path :: Path
path) =
let f' :: Path
f' = Path -> Path -> Path
relativize Path
f Path
path
in case Worth Path -> HashMap (Worth Path) [Directive] -> Maybe [Directive]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (Path -> Worth Path
forall b. b -> Worth b
Required (Path -> Path -> Path
relativize Path
f Path
path)) HashMap (Worth Path) [Directive]
files of
Just ds :: [Directive]
ds -> (HashMap Path Value -> Directive -> IO (HashMap Path Value))
-> HashMap Path Value -> [Directive] -> IO (HashMap Path Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Path
-> Path
-> HashMap Path Value
-> Directive
-> IO (HashMap Path Value)
directive Path
pfx Path
f') HashMap Path Value
m [Directive]
ds
_ -> HashMap Path Value -> IO (HashMap Path Value)
forall (m :: * -> *) a. Monad m => a -> m a
return HashMap Path Value
m
interpolate :: T.Text -> T.Text -> H.HashMap Name Value -> IO T.Text
interpolate :: Path -> Path -> HashMap Path Value -> IO Path
interpolate pfx :: Path
pfx s :: Path
s env :: HashMap Path Value
env
| "$" Path -> Path -> Bool
`T.isInfixOf` Path
s =
case Parser [Interpolate] -> Path -> Either FilePath [Interpolate]
forall a. Parser a -> Path -> Either FilePath a
T.parseOnly Parser [Interpolate]
interp Path
s of
Left err :: FilePath
err -> ConfigError -> IO Path
forall e a. Exception e => e -> IO a
throwIO (ConfigError -> IO Path) -> ConfigError -> IO Path
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> ConfigError
ParseError "" FilePath
err
Right xs :: [Interpolate]
xs -> (Text -> Path
L.toStrict (Text -> Path) -> ([Builder] -> Text) -> [Builder] -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text) -> ([Builder] -> Builder) -> [Builder] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat) ([Builder] -> Path) -> IO [Builder] -> IO Path
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)
mapM Interpolate -> IO Builder
interpret [Interpolate]
xs
| Bool
otherwise = Path -> IO Path
forall (m :: * -> *) a. Monad m => a -> m a
return Path
s
where
lookupEnv :: Path -> Maybe Value
lookupEnv name :: Path
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
$ (Path -> Maybe Value) -> [Path] -> [Maybe Value]
forall a b. (a -> b) -> [a] -> [b]
map ((Path -> HashMap Path Value -> Maybe Value)
-> HashMap Path Value -> Path -> Maybe Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Path -> HashMap Path Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup HashMap Path Value
env) [Path]
fullnames
where fullnames :: [Path]
fullnames = ([Path] -> Path) -> [[Path]] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map (Path -> [Path] -> Path
T.intercalate ".")
([[Path]] -> [Path]) -> (Path -> [[Path]]) -> Path -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Path] -> [Path]) -> [[Path]] -> [[Path]]
forall a b. (a -> b) -> [a] -> [b]
map ([Path] -> [Path]
forall a. [a] -> [a]
reverse ([Path] -> [Path]) -> ([Path] -> [Path]) -> [Path] -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path
namePath -> [Path] -> [Path]
forall a. a -> [a] -> [a]
:))
([[Path]] -> [[Path]]) -> (Path -> [[Path]]) -> Path -> [[Path]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Path] -> [[Path]]
forall a. [a] -> [[a]]
tails
([Path] -> [[Path]]) -> (Path -> [Path]) -> Path -> [[Path]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Path] -> [Path]
forall a. [a] -> [a]
reverse
([Path] -> [Path]) -> (Path -> [Path]) -> Path -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Bool) -> [Path] -> [Path]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Path -> Bool) -> Path -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Bool
T.null)
([Path] -> [Path]) -> (Path -> [Path]) -> Path -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Path -> [Path]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='.')
(Path -> [Path]) -> Path -> [Path]
forall a b. (a -> b) -> a -> b
$ Path
pfx
interpret :: Interpolate -> IO Builder
interpret (Literal x :: Path
x) = Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Path -> Builder
fromText Path
x)
interpret (Interpolate name :: Path
name) =
case Path -> Maybe Value
lookupEnv Path
name of
Just (String x :: Path
x) -> Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Path -> Builder
fromText Path
x)
Just (Number r :: Rational
r)
| Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 1 -> Builder -> IO Builder
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 (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)
Just _ -> FilePath -> IO Builder
forall a. HasCallStack => FilePath -> a
error "type error"
_ -> do
Either SomeException FilePath
e <- IO FilePath -> IO (Either SomeException FilePath)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO FilePath -> IO (Either SomeException FilePath))
-> (Path -> IO FilePath)
-> Path
-> IO (Either SomeException FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
getEnv (FilePath -> IO FilePath)
-> (Path -> FilePath) -> Path -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> FilePath
T.unpack (Path -> IO (Either SomeException FilePath))
-> Path -> IO (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ Path
name
case Either SomeException FilePath
e of
Left (SomeException
_::SomeException) ->
ConfigError -> IO Builder
forall e a. Exception e => e -> IO a
throwIO (ConfigError -> IO Builder)
-> (FilePath -> ConfigError) -> FilePath -> IO Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> ConfigError
ParseError "" (FilePath -> IO Builder) -> FilePath -> IO Builder
forall a b. (a -> b) -> a -> b
$ "no such variable " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path -> FilePath
forall a. Show a => a -> FilePath
show Path
name
Right x :: FilePath
x -> Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Builder
fromString FilePath
x)
importsOf :: Path -> [Directive] -> [Worth Path]
importsOf :: Path -> [Directive] -> [Worth Path]
importsOf path :: Path
path (Import ref :: Path
ref : xs :: [Directive]
xs) = Path -> Worth Path
forall b. b -> Worth b
Required (Path -> Path -> Path
relativize Path
path Path
ref)
Worth Path -> [Worth Path] -> [Worth Path]
forall a. a -> [a] -> [a]
: Path -> [Directive] -> [Worth Path]
importsOf Path
path [Directive]
xs
importsOf path :: Path
path (Group _ ys :: [Directive]
ys : xs :: [Directive]
xs) = Path -> [Directive] -> [Worth Path]
importsOf Path
path [Directive]
ys [Worth Path] -> [Worth Path] -> [Worth Path]
forall a. [a] -> [a] -> [a]
++ Path -> [Directive] -> [Worth Path]
importsOf Path
path [Directive]
xs
importsOf path :: Path
path (_ : xs :: [Directive]
xs) = Path -> [Directive] -> [Worth Path]
importsOf Path
path [Directive]
xs
importsOf _ _ = []
relativize :: Path -> Path -> Path
relativize :: Path -> Path -> Path
relativize parent :: Path
parent child :: Path
child
| Path -> Char
T.head Path
child Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/' = Path
child
| Bool
otherwise = (Path, Path) -> Path
forall a b. (a, b) -> a
fst (Path -> Path -> (Path, Path)
T.breakOnEnd "/" Path
parent) Path -> Path -> Path
`T.append` Path
child
loadOne :: Worth FilePath -> IO [Directive]
loadOne :: Worth FilePath -> IO [Directive]
loadOne path :: Worth FilePath
path = do
Either SomeException Text
es <- IO Text -> IO (Either SomeException Text)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Text -> IO (Either SomeException Text))
-> (Worth FilePath -> IO Text)
-> Worth FilePath
-> IO (Either SomeException Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Text
L.readFile (FilePath -> IO Text)
-> (Worth FilePath -> FilePath) -> Worth FilePath -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Worth FilePath -> FilePath
forall a. Worth a -> a
worth (Worth FilePath -> IO (Either SomeException Text))
-> Worth FilePath -> IO (Either SomeException Text)
forall a b. (a -> b) -> a -> b
$ Worth FilePath
path
case Either SomeException Text
es of
Left (SomeException
err::SomeException) -> case Worth FilePath
path of
Required _ -> SomeException -> IO [Directive]
forall e a. Exception e => e -> IO a
throwIO SomeException
err
_ -> [Directive] -> IO [Directive]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Right s :: Text
s -> do
Either FilePath [Directive]
p <- Either FilePath [Directive] -> IO (Either FilePath [Directive])
forall a. a -> IO a
evaluate (Result [Directive] -> Either FilePath [Directive]
forall r. Result r -> Either FilePath r
L.eitherResult (Result [Directive] -> Either FilePath [Directive])
-> Result [Directive] -> Either FilePath [Directive]
forall a b. (a -> b) -> a -> b
$ Parser [Directive] -> Text -> Result [Directive]
forall a. Parser a -> Text -> Result a
L.parse Parser [Directive]
topLevel Text
s)
IO (Either FilePath [Directive])
-> (ConfigError -> IO (Either FilePath [Directive]))
-> IO (Either FilePath [Directive])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(ConfigError
e::ConfigError) ->
ConfigError -> IO (Either FilePath [Directive])
forall e a. Exception e => e -> IO a
throwIO (ConfigError -> IO (Either FilePath [Directive]))
-> ConfigError -> IO (Either FilePath [Directive])
forall a b. (a -> b) -> a -> b
$ case ConfigError
e of
ParseError _ err :: FilePath
err -> FilePath -> FilePath -> ConfigError
ParseError (Worth FilePath -> FilePath
forall a. Worth a -> a
worth Worth FilePath
path) FilePath
err
case Either FilePath [Directive]
p of
Left err :: FilePath
err -> ConfigError -> IO [Directive]
forall e a. Exception e => e -> IO a
throwIO (FilePath -> FilePath -> ConfigError
ParseError (Worth FilePath -> FilePath
forall a. Worth a -> a
worth Worth FilePath
path) FilePath
err)
Right ds :: [Directive]
ds -> [Directive] -> IO [Directive]
forall (m :: * -> *) a. Monad m => a -> m a
return [Directive]
ds
subscribe :: Config -> Pattern -> ChangeHandler -> IO ()
subscribe :: Config -> Pattern -> ChangeHandler -> IO ()
subscribe (Config root :: Path
root BaseConfig{..}) pat :: Pattern
pat act :: ChangeHandler
act = do
HashMap Pattern [ChangeHandler]
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
$ \m :: 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]
(++) (Path -> Pattern -> Pattern
localPattern Path
root Pattern
pat) [ChangeHandler
act] HashMap Pattern [ChangeHandler]
m in (HashMap Pattern [ChangeHandler]
m', HashMap Pattern [ChangeHandler]
m')
HashMap Pattern [ChangeHandler]
-> IO (HashMap Pattern [ChangeHandler])
forall a. a -> IO a
evaluate HashMap Pattern [ChangeHandler]
m' IO (HashMap Pattern [ChangeHandler]) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
localPattern :: Name -> Pattern -> Pattern
localPattern :: Path -> Pattern -> Pattern
localPattern pfx :: Path
pfx (Exact s :: Path
s) = Path -> Pattern
Exact (Path
pfx Path -> Path -> Path
`T.append` Path
s)
localPattern pfx :: Path
pfx (Prefix s :: Path
s) = Path -> Pattern
Prefix (Path
pfx Path -> Path -> Path
`T.append` Path
s)
notifySubscribers :: BaseConfig -> H.HashMap Name Value -> H.HashMap Name Value
-> H.HashMap Pattern [ChangeHandler] -> IO ()
notifySubscribers :: BaseConfig
-> HashMap Path Value
-> HashMap Path Value
-> HashMap Pattern [ChangeHandler]
-> IO ()
notifySubscribers BaseConfig{..} m :: HashMap Path Value
m m' :: HashMap Path Value
m' subs :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()) HashMap Pattern [ChangeHandler]
subs
where
changedOrGone :: [(Path, Maybe Value)]
changedOrGone = (Path -> Value -> [(Path, Maybe Value)] -> [(Path, Maybe Value)])
-> [(Path, Maybe Value)]
-> HashMap Path Value
-> [(Path, Maybe Value)]
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
H.foldrWithKey Path -> Value -> [(Path, Maybe Value)] -> [(Path, Maybe Value)]
check [] HashMap Path Value
m
where check :: Path -> Value -> [(Path, Maybe Value)] -> [(Path, Maybe Value)]
check n :: Path
n v :: Value
v nvs :: [(Path, Maybe Value)]
nvs = case Path -> HashMap Path Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Path
n HashMap Path Value
m' of
Just v' :: Value
v' | Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
v' -> (Path
n,Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v')(Path, Maybe Value)
-> [(Path, Maybe Value)] -> [(Path, Maybe Value)]
forall a. a -> [a] -> [a]
:[(Path, Maybe Value)]
nvs
| Bool
otherwise -> [(Path, Maybe Value)]
nvs
_ -> (Path
n,Maybe Value
forall a. Maybe a
Nothing)(Path, Maybe Value)
-> [(Path, Maybe Value)] -> [(Path, Maybe Value)]
forall a. a -> [a] -> [a]
:[(Path, Maybe Value)]
nvs
new :: [(Path, Value)]
new = (Path -> Value -> [(Path, Value)] -> [(Path, Value)])
-> [(Path, Value)] -> HashMap Path Value -> [(Path, Value)]
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
H.foldrWithKey Path -> Value -> [(Path, Value)] -> [(Path, Value)]
forall b. Path -> b -> [(Path, b)] -> [(Path, b)]
check [] HashMap Path Value
m'
where check :: Path -> b -> [(Path, b)] -> [(Path, b)]
check n :: Path
n v :: b
v nvs :: [(Path, b)]
nvs = case Path -> HashMap Path Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Path
n HashMap Path Value
m of
Nothing -> (Path
n,b
v)(Path, b) -> [(Path, b)] -> [(Path, b)]
forall a. a -> [a] -> [a]
:[(Path, b)]
nvs
_ -> [(Path, b)]
nvs
notify :: a -> b -> t -> (b -> t -> IO ()) -> IO ()
notify p :: a
p n :: b
n v :: t
v a :: b -> t -> IO ()
a = b -> t -> IO ()
a b
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 e :: a
e = Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
"*** a ChangeHandler threw an exception for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
(a, b) -> FilePath
forall a. Show a => a -> FilePath
show (a
p,b
n) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
e
go :: Pattern -> t ChangeHandler -> IO b -> IO b
go p :: Pattern
p@(Exact n :: Path
n) acts :: t ChangeHandler
acts next :: 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' = Path -> HashMap Path Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Path
n HashMap Path Value
m'
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Path -> HashMap Path Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Path
n HashMap Path 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 -> Path -> Maybe Value -> ChangeHandler -> IO ()
forall a b t.
(Show a, Show b) =>
a -> b -> t -> (b -> t -> IO ()) -> IO ()
notify Pattern
p Path
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 n :: Path
n) acts :: t ChangeHandler
acts next :: 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 :: [(Path, b)] -> [(Path, b)]
matching = ((Path, b) -> Bool) -> [(Path, b)] -> [(Path, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Path -> Path -> Bool
T.isPrefixOf Path
n (Path -> Bool) -> ((Path, b) -> Path) -> (Path, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path, b) -> Path
forall a b. (a, b) -> a
fst)
[(Path, Value)] -> ((Path, Value) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Path, Value)] -> [(Path, Value)]
forall b. [(Path, b)] -> [(Path, b)]
matching [(Path, Value)]
new) (((Path, Value) -> IO ()) -> IO ())
-> ((Path, Value) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(n' :: Path
n',v :: Value
v) -> (ChangeHandler -> IO ()) -> t ChangeHandler -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern -> Path -> Maybe Value -> ChangeHandler -> IO ()
forall a b t.
(Show a, Show b) =>
a -> b -> t -> (b -> t -> IO ()) -> IO ()
notify Pattern
p Path
n' (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v)) t ChangeHandler
acts
[(Path, Maybe Value)] -> ((Path, Maybe Value) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Path, Maybe Value)] -> [(Path, Maybe Value)]
forall b. [(Path, b)] -> [(Path, b)]
matching [(Path, Maybe Value)]
changedOrGone) (((Path, Maybe Value) -> IO ()) -> IO ())
-> ((Path, Maybe Value) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(n' :: Path
n',v :: 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 -> Path -> Maybe Value -> ChangeHandler -> IO ()
forall a b t.
(Show a, Show b) =>
a -> b -> t -> (b -> t -> IO ()) -> IO ()
notify Pattern
p Path
n' Maybe Value
v) t ChangeHandler
acts
empty :: Config
empty :: Config
empty = Path -> BaseConfig -> Config
Config "" (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
IORef [(Path, Worth Path)]
p <- [(Path, Worth Path)] -> IO (IORef [(Path, Worth Path)])
forall a. a -> IO (IORef a)
newIORef []
IORef (HashMap Path Value)
m <- HashMap Path Value -> IO (IORef (HashMap Path Value))
forall a. a -> IO (IORef a)
newIORef HashMap Path Value
forall k v. HashMap k v
H.empty
IORef (HashMap Pattern [ChangeHandler])
s <- HashMap Pattern [ChangeHandler]
-> IO (IORef (HashMap Pattern [ChangeHandler]))
forall a. a -> IO (IORef a)
newIORef HashMap Pattern [ChangeHandler]
forall k v. HashMap k v
H.empty
BaseConfig -> IO BaseConfig
forall (m :: * -> *) a. Monad m => a -> m a
return BaseConfig :: Maybe AutoConfig
-> IORef [(Path, Worth Path)]
-> IORef (HashMap Path Value)
-> IORef (HashMap Pattern [ChangeHandler])
-> BaseConfig
BaseConfig {
cfgAuto :: Maybe AutoConfig
cfgAuto = Maybe AutoConfig
forall a. Maybe a
Nothing
, cfgPaths :: IORef [(Path, Worth Path)]
cfgPaths = IORef [(Path, Worth Path)]
p
, cfgMap :: IORef (HashMap Path Value)
cfgMap = IORef (HashMap Path Value)
m
, cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
cfgSubs = IORef (HashMap Pattern [ChangeHandler])
s
}
{-# NOINLINE empty #-}