module Data.Yaml.Config.Internal
( Config(..)
, Key
, load
, keys
, lookupSubconfig
, subconfig
, lookup
, lookupDefault
, require
, fullpath
) where
import Prelude hiding (lookup)
import Control.DeepSeq (NFData(rnf))
import Control.Exception (Exception, throwIO)
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
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 :: Key -> IO a
ke = throwIO . KeyError
fullpath :: Config -> Key -> Key
fullpath (Config parents _) path = ST.intercalate "." $
reverse $ path : parents
load :: FilePath -> IO Config
load f = maybe err (return . Config []) =<< Yaml.decodeFile f
where
err = error $ "Invalid config file " <> f <> "."
keys :: Config -> [Key]
keys (Config _ o) = HashMap.keys o
lookup :: FromJSON a
=> Config
-> Key
-> Maybe a
lookup conf path = foldM lookupSubconfig conf (init pathes) >>=
look (last pathes)
where
look k (Config _ o) = HashMap.lookup k o >>= parseMaybe parseJSON
pathes = ST.splitOn "." path
lookupSubconfig :: Config
-> Key
-> Maybe Config
lookupSubconfig (Config parents o) k = HashMap.lookup k o >>= \s -> case s of
(Yaml.Object so) -> Just $ Config (k : parents) so
_ -> Nothing
lookupDefault :: FromJSON a
=> Config
-> Key
-> a
-> a
lookupDefault c p d = fromMaybe d $ lookup c p
subconfig :: Config
-> Key
-> IO Config
subconfig c path = maybe err return $ lookupSubconfig c path
where
err = ke $ "Subconfig " <> fullpath c path <> " not found."
require :: FromJSON a => Config -> Key -> IO a
require c path = maybe err return $ lookup c path
where
err = ke $ "Field " <> fullpath c path <> " not found or has wrong type."