module Data.Yaml.Config.Internal
( Config(..)
, KeyError(..)
, Key
, load
, keys
, subconfig
, lookup
, lookupDefault
, fullpath
) where
import Prelude hiding (lookup)
import Control.DeepSeq (NFData(rnf))
import Control.Exception (Exception)
import Control.Monad (foldM)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Typeable (Typeable)
import qualified Data.Text as ST
import Data.Yaml (Object, FromJSON(parseJSON), parseMaybe)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Yaml as Yaml
import qualified Data.Yaml.Include as YamlInclude
import Control.Failure
type Key = ST.Text
newtype KeyError = KeyError Key
deriving (Show, Typeable)
instance Exception KeyError
data Config = Config [Key] Object
deriving (Eq, Show)
instance NFData Config where
rnf (Config p o) = rnf p `seq` rnf o `seq` ()
ke :: Failure KeyError m => Key -> m a
ke = failure . KeyError
fullpath :: Config -> Key -> Key
fullpath (Config parents _) path = ST.intercalate "." $
reverse $ path : parents
load :: FilePath -> IO Config
load f = maybe err (return . Config []) =<< YamlInclude.decodeFile f
where
err = error $ "Invalid config file " <> f <> "."
keys :: Config -> [Key]
keys (Config _ o) = HashMap.keys o
lookup :: (Failure KeyError m, FromJSON a)
=> Key
-> Config
-> m a
lookup path c = maybe err return $ lookupMaybe path c
where
err = ke $ "Field " <> fullpath c path <> " not found or has wrong type."
lookupMaybe :: FromJSON a => Key -> Config -> Maybe a
lookupMaybe path conf = foldM (flip subconfig) conf (init pathes) >>=
look (last pathes)
where
look k (Config _ o) = HashMap.lookup k o >>= parseMaybe parseJSON
pathes = ST.splitOn "." path
lookupDefault :: FromJSON a
=> Key
-> a
-> Config
-> a
lookupDefault p d = fromMaybe d . lookup p
subconfig :: Failure KeyError m
=> Key
-> Config
-> m Config
subconfig path c@(Config parents o) = case HashMap.lookup path o of
Just (Yaml.Object so) -> return $ Config (path : parents) so
_ -> err
where
err = ke $ "Subconfig " <> fullpath c path <> " not found."