{-# 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 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
Worth Text
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
[Directive]
ds <- Worth FilePath -> IO [Directive]
loadOne (Text -> FilePath
T.unpack (Text -> FilePath) -> Worth Text -> Worth FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Worth Text
path')
let !seen' :: HashMap (Worth Text) [Directive]
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 -> Bool
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
(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]
seen' ([Worth Text] -> IO (HashMap (Worth Text) [Directive]))
-> ([Directive] -> [Worth Text])
-> [Directive]
-> IO (HashMap (Worth Text) [Directive])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Worth Text -> Bool) -> [Worth Text] -> [Worth Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Worth Text -> Bool
notSeen ([Worth Text] -> [Worth Text])
-> ([Directive] -> [Worth Text]) -> [Directive] -> [Worth Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Directive] -> [Worth Text]
importsOf Text
wpath ([Directive] -> IO (HashMap (Worth Text) [Directive]))
-> [Directive] -> IO (HashMap (Worth Text) [Directive])
forall a b. (a -> b) -> a -> b
$ [Directive]
ds
load :: [Worth FilePath] -> IO Config
load :: [Worth FilePath] -> IO Config
load [Worth FilePath]
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 FilePath)] -> IO BaseConfig
load' Maybe AutoConfig
forall a. Maybe a
Nothing ((Worth FilePath -> (Text, Worth FilePath))
-> [Worth FilePath] -> [(Text, Worth FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\Worth FilePath
f -> (Text
"", Worth FilePath
f)) [Worth FilePath]
files)
loadGroups :: [(Name, Worth FilePath)] -> IO Config
loadGroups :: [(Text, Worth FilePath)] -> IO Config
loadGroups [(Text, Worth FilePath)]
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 FilePath)] -> IO BaseConfig
load' Maybe AutoConfig
forall a. Maybe a
Nothing [(Text, Worth FilePath)]
files
load' :: Maybe AutoConfig -> [(Name, Worth FilePath)] -> IO BaseConfig
load' :: Maybe AutoConfig -> [(Text, Worth FilePath)] -> IO BaseConfig
load' Maybe AutoConfig
auto [(Text, Worth FilePath)]
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 FilePath) -> (Text, Worth Text))
-> [(Text, Worth FilePath)] -> [(Text, Worth Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Worth FilePath -> Worth Text)
-> (Text, Worth FilePath) -> (Text, Worth Text)
forall {t} {b} {a}. (t -> b) -> (a, t) -> (a, b)
second ((FilePath -> Text) -> Worth FilePath -> Worth Text
forall a b. (a -> b) -> Worth a -> Worth b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
T.pack)) [(Text, Worth FilePath)]
paths0
HashMap (Worth Text) [Directive]
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)
IORef [(Text, Worth Text)]
p <- [(Text, Worth Text)] -> IO (IORef [(Text, Worth Text)])
forall a. a -> IO (IORef a)
newIORef [(Text, Worth Text)]
paths
IORef (HashMap Text Value)
m <- HashMap Text Value -> IO (IORef (HashMap Text Value))
forall a. a -> IO (IORef a)
newIORef (HashMap Text Value -> IO (IORef (HashMap Text Value)))
-> IO (HashMap Text Value) -> IO (IORef (HashMap Text Value))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Text, Worth Text)]
-> HashMap (Worth Text) [Directive] -> IO (HashMap Text Value)
flatten [(Text, Worth Text)]
paths HashMap (Worth Text) [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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BaseConfig {
cfgAuto :: Maybe AutoConfig
cfgAuto = Maybe AutoConfig
auto
, cfgPaths :: IORef [(Text, Worth Text)]
cfgPaths = IORef [(Text, Worth Text)]
p
, cfgMap :: IORef (HashMap Text Value)
cfgMap = IORef (HashMap Text Value)
m
, cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
cfgSubs = IORef (HashMap Pattern [ChangeHandler])
s
}
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
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
[(Text, Worth Text)]
paths <- IORef [(Text, Worth Text)] -> IO [(Text, Worth Text)]
forall a. IORef a -> IO a
readIORef IORef [(Text, Worth Text)]
cfgPaths
HashMap Text Value
m' <- [(Text, Worth Text)]
-> HashMap (Worth Text) [Directive] -> IO (HashMap Text Value)
flatten [(Text, Worth Text)]
paths (HashMap (Worth Text) [Directive] -> IO (HashMap Text Value))
-> IO (HashMap (Worth Text) [Directive]) -> IO (HashMap Text Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [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)
HashMap Text Value
m <- IORef (HashMap Text Value)
-> (HashMap Text Value -> (HashMap Text Value, HashMap Text Value))
-> IO (HashMap Text Value)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap Text Value)
cfgMap ((HashMap Text Value -> (HashMap Text Value, HashMap Text Value))
-> IO (HashMap Text Value))
-> (HashMap Text Value -> (HashMap Text Value, HashMap Text Value))
-> IO (HashMap Text Value)
forall a b. (a -> b) -> a -> b
$ \HashMap Text Value
m -> (HashMap Text Value
m', HashMap Text Value
m)
BaseConfig
-> HashMap Text Value
-> HashMap Text Value
-> HashMap Pattern [ChangeHandler]
-> IO ()
notifySubscribers BaseConfig
cfg HashMap Text Value
m HashMap Text 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 [Worth FilePath]
paths0 Config
cfg = [(Text, Worth FilePath)] -> Config -> IO ()
addGroupsToConfig ((Worth FilePath -> (Text, Worth FilePath))
-> [Worth FilePath] -> [(Text, Worth FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\Worth FilePath
x -> (Text
"",Worth FilePath
x)) [Worth FilePath]
paths0) Config
cfg
addGroupsToConfig :: [(Name, Worth FilePath)] -> Config -> IO ()
addGroupsToConfig :: [(Text, Worth FilePath)] -> Config -> IO ()
addGroupsToConfig [(Text, Worth FilePath)]
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 FilePath) -> (Text, f Text)
fix (Text
x,f FilePath
y) = (Text
root Text -> Text -> Text
`T.append` Text
x, (FilePath -> Text) -> f FilePath -> f Text
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
T.pack f FilePath
y)
paths :: [(Text, Worth Text)]
paths = ((Text, Worth FilePath) -> (Text, Worth Text))
-> [(Text, Worth FilePath)] -> [(Text, Worth Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Worth FilePath) -> (Text, Worth Text)
forall {f :: * -> *}.
Functor f =>
(Text, f FilePath) -> (Text, f Text)
fix [(Text, Worth FilePath)]
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
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 ()
}
autoReload :: AutoConfig
-> [Worth FilePath]
-> IO (Config, ThreadId)
autoReload :: AutoConfig -> [Worth FilePath] -> IO (Config, ThreadId)
autoReload AutoConfig
auto [Worth FilePath]
paths = AutoConfig -> [(Text, Worth FilePath)] -> IO (Config, ThreadId)
autoReloadGroups AutoConfig
auto ((Worth FilePath -> (Text, Worth FilePath))
-> [Worth FilePath] -> [(Text, Worth FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\Worth FilePath
x -> (Text
"", Worth FilePath
x)) [Worth FilePath]
paths)
autoReloadGroups :: AutoConfig
-> [(Name, Worth FilePath)]
-> IO (Config, ThreadId)
autoReloadGroups :: AutoConfig -> [(Text, Worth FilePath)] -> IO (Config, ThreadId)
autoReloadGroups AutoConfig{Int
SomeException -> IO ()
interval :: AutoConfig -> Int
onError :: AutoConfig -> SomeException -> IO ()
interval :: Int
onError :: SomeException -> IO ()
..} [(Text, Worth FilePath)]
_
| Int
interval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = FilePath -> IO (Config, ThreadId)
forall a. HasCallStack => FilePath -> a
error FilePath
"autoReload: negative interval"
autoReloadGroups AutoConfig
_ [] = FilePath -> IO (Config, ThreadId)
forall a. HasCallStack => FilePath -> a
error FilePath
"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 FilePath)]
paths = do
BaseConfig
cfg <- Maybe AutoConfig -> [(Text, Worth FilePath)] -> IO BaseConfig
load' (AutoConfig -> Maybe AutoConfig
forall a. a -> Maybe a
Just AutoConfig
auto) [(Text, Worth FilePath)]
paths
let files :: [Worth FilePath]
files = ((Text, Worth FilePath) -> Worth FilePath)
-> [(Text, Worth FilePath)] -> [Worth FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Worth FilePath) -> Worth FilePath
forall a b. (a, b) -> b
snd [(Text, Worth FilePath)]
paths
loop :: [Maybe Meta] -> IO b
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)
[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 a b. IO a -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> BaseConfig -> Config
Config Text
"" BaseConfig
cfg, ThreadId
tid)
type Meta = (FileOffset, EpochTime)
getMeta :: [Worth FilePath] -> IO [Maybe Meta]
getMeta :: [Worth FilePath] -> IO [Maybe Meta]
getMeta [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
$ \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 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
FileStatus
st <- FilePath -> IO FileStatus
getFileStatus (Worth FilePath -> FilePath
forall a. Worth a -> a
worth Worth FilePath
path)
Meta -> IO Meta
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> COff
fileSize FileStatus
st, FileStatus -> CTime
modificationTime FileStatus
st)
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
require :: Configured a => Config -> Name -> IO a
require :: forall a. Configured a => Config -> Text -> IO a
require Config
cfg Text
name = do
Maybe a
val <- Config -> Text -> IO (Maybe a)
forall a. Configured a => Config -> Text -> IO (Maybe a)
lookup Config
cfg Text
name
case Maybe a
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. 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
lookupDefault :: Configured a =>
a
-> 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
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
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
Text
v <- Text -> Text -> HashMap Text Value -> IO Text
interpolate Text
pfx Text
value HashMap Text Value
m
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) (Text -> Value
String Text
v) HashMap Text Value
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 FilePath [Interpolate]
forall a. Parser a -> Text -> Either FilePath a
T.parseOnly Parser [Interpolate]
interp Text
s of
Left FilePath
err -> ConfigError -> IO Text
forall e a. Exception e => e -> IO a
throwIO (ConfigError -> IO Text) -> ConfigError -> IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> ConfigError
ParseError FilePath
"" FilePath
err
Right [Interpolate]
xs -> (Text -> Text
L.toStrict (Text -> Text) -> ([Builder] -> Text) -> [Builder] -> Text
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] -> 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
".")
([[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]
:))
([[Text]] -> [[Text]]) -> (Text -> [[Text]]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [[Text]]
forall a. [a] -> [[a]]
tails
([Text] -> [[Text]]) -> (Text -> [Text]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse
([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)
([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
'.')
(Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
pfx
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)
Just Value
_ -> FilePath -> IO Builder
forall a. HasCallStack => FilePath -> a
error FilePath
"type error"
Maybe Value
_ -> 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))
-> (Text -> IO FilePath)
-> Text
-> IO (Either SomeException FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
getEnv (FilePath -> IO FilePath)
-> (Text -> FilePath) -> Text -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> IO (Either SomeException FilePath))
-> Text -> IO (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ Text
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
"" (FilePath -> IO Builder) -> FilePath -> IO Builder
forall a b. (a -> b) -> a -> b
$ FilePath
"no such variable " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
name
Right FilePath
x -> Builder -> IO Builder
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Builder
fromString FilePath
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 FilePath -> IO [Directive]
loadOne 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 FilePath
_ -> SomeException -> IO [Directive]
forall e a. Exception e => e -> IO a
throwIO SomeException
err
Worth FilePath
_ -> [Directive] -> IO [Directive]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Right 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 FilePath
_ 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 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 [Directive]
ds -> [Directive] -> IO [Directive]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Directive]
ds
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
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
$ \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')
HashMap Pattern [ChangeHandler]
-> IO (HashMap Pattern [ChangeHandler])
forall a. a -> IO a
evaluate HashMap Pattern [ChangeHandler]
m' IO (HashMap Pattern [ChangeHandler]) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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 -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath
"*** a ChangeHandler threw an exception for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
(p, t) -> FilePath
forall a. Show a => a -> FilePath
show (p
p,t
n) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " 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 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
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
IORef [(Text, Worth Text)]
p <- [(Text, Worth Text)] -> IO (IORef [(Text, Worth Text)])
forall a. a -> IO (IORef a)
newIORef []
IORef (HashMap Text Value)
m <- HashMap Text Value -> IO (IORef (HashMap Text Value))
forall a. a -> IO (IORef a)
newIORef HashMap Text 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BaseConfig {
cfgAuto :: Maybe AutoConfig
cfgAuto = Maybe AutoConfig
forall a. Maybe a
Nothing
, cfgPaths :: IORef [(Text, Worth Text)]
cfgPaths = IORef [(Text, Worth Text)]
p
, cfgMap :: IORef (HashMap Text Value)
cfgMap = IORef (HashMap Text Value)
m
, cfgSubs :: IORef (HashMap Pattern [ChangeHandler])
cfgSubs = IORef (HashMap Pattern [ChangeHandler])
s
}
{-# NOINLINE empty #-}