{-# Language GADTs #-}
module Config.Schema.Load
( loadValue
, loadValueFromFile
, ValueSpecMismatch(..)
, PrimMismatch(..)
, Problem(..)
) where
import Control.Exception (throwIO)
import Control.Monad (zipWithM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT(..), runStateT, state)
import Control.Monad.Trans.Except (Except, runExcept, throwE, withExcept)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text.IO as Text
import Config
import Config.Schema.Types
import Config.Schema.Load.Error
loadValue ::
ValueSpec a ->
Value p ->
Either (ValueSpecMismatch p) a
loadValue spec val = runExcept (getValue spec val)
loadValueFromFile ::
ValueSpec a ->
FilePath ->
IO a
loadValueFromFile spec path =
do txt <- Text.readFile path
let exceptIO m = either throwIO return m
val <- exceptIO (parse txt)
exceptIO (loadValue spec val)
getSection :: PrimSectionSpec a -> StateT [Section p] (Except (Problem p)) a
getSection (ReqSection k _ w) =
do mb <- state (lookupSection k)
lift $ case mb of
Just v -> getValue' (SubkeyProblem k) w v
Nothing -> throwE (MissingSection k)
getSection (OptSection k _ w) =
do mb <- state (lookupSection k)
lift (traverse (getValue' (SubkeyProblem k) w) mb)
getSections :: SectionsSpec a -> [Section p] -> Except (Problem p) a
getSections spec xs =
do (a,leftovers) <- runStateT (runSections getSection spec) xs
case NonEmpty.nonEmpty leftovers of
Nothing -> return a
Just ss -> throwE (UnusedSections (fmap sectionName ss))
getValue :: ValueSpec a -> Value p -> Except (ValueSpecMismatch p) a
getValue s v = withExcept (ValueSpecMismatch (valueAnn v) (describeValue v)) (runValueSpec (getValue1 v) s)
getValue' ::
(ValueSpecMismatch p -> Problem p) ->
ValueSpec a ->
Value p ->
Except (Problem p) a
getValue' p s v = withExcept (p . ValueSpecMismatch (valueAnn v) (describeValue v)) (runValueSpec (getValue1 v) s)
getValue1 :: Value p -> PrimValueSpec a -> Except (NonEmpty (PrimMismatch p)) a
getValue1 v prim = withExcept (pure . PrimMismatch (describeSpec prim))
(getValue2 v prim)
getValue2 :: Value p -> PrimValueSpec a -> Except (Problem p) a
getValue2 (Text _ t) TextSpec = pure t
getValue2 (Number _ n) NumberSpec = pure n
getValue2 (List _ xs) (ListSpec w) = getList w xs
getValue2 (Atom _ b) AnyAtomSpec = pure (atomName b)
getValue2 (Atom _ b) (AtomSpec a)
| a == atomName b = pure ()
| otherwise = throwE WrongAtom
getValue2 (Sections _ s) (SectionsSpec _ w) = getSections w s
getValue2 (Sections _ s) (AssocSpec w) = getAssoc w s
getValue2 v (NamedSpec _ w) = getValue' NestedProblem w v
getValue2 v (CustomSpec _ w) = getCustom w v
getValue2 _ _ = throwE TypeMismatch
getList :: ValueSpec a -> [Value p] -> Except (Problem p) [a]
getList w = zipWithM (\i -> getValue' (ListElementProblem i) w) [1::Int ..]
getAssoc :: ValueSpec a -> [Section p] -> Except (Problem p) [(Text,a)]
getAssoc w = traverse $ \(Section _ k v) ->
(,) k <$> getValue' (SubkeyProblem k) w v
getCustom ::
ValueSpec (Either Text a) ->
Value p ->
Except (Problem p) a
getCustom w v = either (throwE . CustomProblem) pure =<< getValue' NestedProblem w v
lookupSection ::
Text ->
[Section p] ->
(Maybe (Value p), [Section p])
lookupSection _ [] = (Nothing, [])
lookupSection key (s@(Section _ k v):xs)
| key == k = (Just v, xs)
| otherwise = case lookupSection key xs of
(res, xs') -> (res, s:xs')