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 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 []) =<< Yaml.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."