{-# 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 :: forall a p.
ValueSpec a -> Value p -> Either (ValueSpecMismatch p) a
loadValue ValueSpec a
spec Value p
val = Except (ValueSpecMismatch p) a -> Either (ValueSpecMismatch p) a
forall e a. Except e a -> Either e a
runExcept (ValueSpec a -> Value p -> Except (ValueSpecMismatch p) a
forall a p.
ValueSpec a -> Value p -> Except (ValueSpecMismatch p) a
getValue ValueSpec a
spec Value p
val)
loadValueFromFile ::
ValueSpec a ->
FilePath ->
IO a
loadValueFromFile :: forall a. ValueSpec a -> FilePath -> IO a
loadValueFromFile ValueSpec a
spec FilePath
path =
do Text
txt <- FilePath -> IO Text
Text.readFile FilePath
path
let exceptIO :: Either a a -> IO a
exceptIO Either a a
m = (a -> IO a) -> (a -> IO a) -> Either a a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either a a
m
Value Position
val <- Either ParseError (Value Position) -> IO (Value Position)
forall {a} {a}. Exception a => Either a a -> IO a
exceptIO (Text -> Either ParseError (Value Position)
parse Text
txt)
Either (ValueSpecMismatch Position) a -> IO a
forall {a} {a}. Exception a => Either a a -> IO a
exceptIO (ValueSpec a
-> Value Position -> Either (ValueSpecMismatch Position) a
forall a p.
ValueSpec a -> Value p -> Either (ValueSpecMismatch p) a
loadValue ValueSpec a
spec Value Position
val)
getSection :: PrimSectionSpec a -> StateT [Section p] (Except (Problem p)) a
getSection :: forall a p.
PrimSectionSpec a -> StateT [Section p] (Except (Problem p)) a
getSection (ReqSection Text
k Text
_ ValueSpec a
w) =
do Maybe (Value p)
mb <- ([Section p] -> (Maybe (Value p), [Section p]))
-> StateT [Section p] (Except (Problem p)) (Maybe (Value p))
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (Text -> [Section p] -> (Maybe (Value p), [Section p])
forall p. Text -> [Section p] -> (Maybe (Value p), [Section p])
lookupSection Text
k)
Except (Problem p) a -> StateT [Section p] (Except (Problem p)) a
forall (m :: * -> *) a. Monad m => m a -> StateT [Section p] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Except (Problem p) a -> StateT [Section p] (Except (Problem p)) a)
-> Except (Problem p) a
-> StateT [Section p] (Except (Problem p)) a
forall a b. (a -> b) -> a -> b
$ case Maybe (Value p)
mb of
Just Value p
v -> (ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> Except (Problem p) a
forall p a.
(ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> Except (Problem p) a
getValue' (Text -> ValueSpecMismatch p -> Problem p
forall p. Text -> ValueSpecMismatch p -> Problem p
SubkeyProblem Text
k) ValueSpec a
w Value p
v
Maybe (Value p)
Nothing -> Problem p -> Except (Problem p) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> Problem p
forall p. Text -> Problem p
MissingSection Text
k)
getSection (OptSection Text
k Text
_ ValueSpec a1
w) =
do Maybe (Value p)
mb <- ([Section p] -> (Maybe (Value p), [Section p]))
-> StateT [Section p] (Except (Problem p)) (Maybe (Value p))
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (Text -> [Section p] -> (Maybe (Value p), [Section p])
forall p. Text -> [Section p] -> (Maybe (Value p), [Section p])
lookupSection Text
k)
Except (Problem p) a -> StateT [Section p] (Except (Problem p)) a
forall (m :: * -> *) a. Monad m => m a -> StateT [Section p] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Value p -> Except (Problem p) a1)
-> Maybe (Value p) -> Except (Problem p) (Maybe a1)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((ValueSpecMismatch p -> Problem p)
-> ValueSpec a1 -> Value p -> Except (Problem p) a1
forall p a.
(ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> Except (Problem p) a
getValue' (Text -> ValueSpecMismatch p -> Problem p
forall p. Text -> ValueSpecMismatch p -> Problem p
SubkeyProblem Text
k) ValueSpec a1
w) Maybe (Value p)
mb)
getSections :: SectionsSpec a -> [Section p] -> Except (Problem p) a
getSections :: forall a p. SectionsSpec a -> [Section p] -> Except (Problem p) a
getSections SectionsSpec a
spec [Section p]
xs =
do (a
a,[Section p]
leftovers) <- StateT [Section p] (ExceptT (Problem p) Identity) a
-> [Section p] -> ExceptT (Problem p) Identity (a, [Section p])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((forall x.
PrimSectionSpec x
-> StateT [Section p] (ExceptT (Problem p) Identity) x)
-> SectionsSpec a
-> StateT [Section p] (ExceptT (Problem p) Identity) a
forall (f :: * -> *) a.
Applicative f =>
(forall x. PrimSectionSpec x -> f x) -> SectionsSpec a -> f a
runSections PrimSectionSpec x
-> StateT [Section p] (ExceptT (Problem p) Identity) x
forall x.
PrimSectionSpec x
-> StateT [Section p] (ExceptT (Problem p) Identity) x
forall a p.
PrimSectionSpec a -> StateT [Section p] (Except (Problem p)) a
getSection SectionsSpec a
spec) [Section p]
xs
case [Section p] -> Maybe (NonEmpty (Section p))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Section p]
leftovers of
Maybe (NonEmpty (Section p))
Nothing -> a -> Except (Problem p) a
forall a. a -> ExceptT (Problem p) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Just NonEmpty (Section p)
ss -> Problem p -> Except (Problem p) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (NonEmpty Text -> Problem p
forall p. NonEmpty Text -> Problem p
UnusedSections ((Section p -> Text) -> NonEmpty (Section p) -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Section p -> Text
forall a. Section a -> Text
sectionName NonEmpty (Section p)
ss))
getValue :: ValueSpec a -> Value p -> Except (ValueSpecMismatch p) a
getValue :: forall a p.
ValueSpec a -> Value p -> Except (ValueSpecMismatch p) a
getValue ValueSpec a
s Value p
v = (NonEmpty (PrimMismatch p) -> ValueSpecMismatch p)
-> Except (NonEmpty (PrimMismatch p)) a
-> Except (ValueSpecMismatch p) a
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept (p -> Text -> NonEmpty (PrimMismatch p) -> ValueSpecMismatch p
forall p.
p -> Text -> NonEmpty (PrimMismatch p) -> ValueSpecMismatch p
ValueSpecMismatch (Value p -> p
forall a. Value a -> a
valueAnn Value p
v) (Value p -> Text
forall p. Value p -> Text
describeValue Value p
v)) ((forall x.
PrimValueSpec x -> ExceptT (NonEmpty (PrimMismatch p)) Identity x)
-> ValueSpec a -> Except (NonEmpty (PrimMismatch p)) a
forall (f :: * -> *) a.
Alt f =>
(forall x. PrimValueSpec x -> f x) -> ValueSpec a -> f a
runValueSpec (Value p -> PrimValueSpec x -> Except (NonEmpty (PrimMismatch p)) x
forall p a.
Value p -> PrimValueSpec a -> Except (NonEmpty (PrimMismatch p)) a
getValue1 Value p
v) ValueSpec a
s)
getValue' ::
(ValueSpecMismatch p -> Problem p) ->
ValueSpec a ->
Value p ->
Except (Problem p) a
getValue' :: forall p a.
(ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> Except (Problem p) a
getValue' ValueSpecMismatch p -> Problem p
p ValueSpec a
s Value p
v = (NonEmpty (PrimMismatch p) -> Problem p)
-> Except (NonEmpty (PrimMismatch p)) a -> Except (Problem p) a
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept (ValueSpecMismatch p -> Problem p
p (ValueSpecMismatch p -> Problem p)
-> (NonEmpty (PrimMismatch p) -> ValueSpecMismatch p)
-> NonEmpty (PrimMismatch p)
-> Problem p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Text -> NonEmpty (PrimMismatch p) -> ValueSpecMismatch p
forall p.
p -> Text -> NonEmpty (PrimMismatch p) -> ValueSpecMismatch p
ValueSpecMismatch (Value p -> p
forall a. Value a -> a
valueAnn Value p
v) (Value p -> Text
forall p. Value p -> Text
describeValue Value p
v)) ((forall x.
PrimValueSpec x -> ExceptT (NonEmpty (PrimMismatch p)) Identity x)
-> ValueSpec a -> Except (NonEmpty (PrimMismatch p)) a
forall (f :: * -> *) a.
Alt f =>
(forall x. PrimValueSpec x -> f x) -> ValueSpec a -> f a
runValueSpec (Value p -> PrimValueSpec x -> Except (NonEmpty (PrimMismatch p)) x
forall p a.
Value p -> PrimValueSpec a -> Except (NonEmpty (PrimMismatch p)) a
getValue1 Value p
v) ValueSpec a
s)
getValue1 :: Value p -> PrimValueSpec a -> Except (NonEmpty (PrimMismatch p)) a
getValue1 :: forall p a.
Value p -> PrimValueSpec a -> Except (NonEmpty (PrimMismatch p)) a
getValue1 Value p
v PrimValueSpec a
prim = (Problem p -> NonEmpty (PrimMismatch p))
-> Except (Problem p) a -> Except (NonEmpty (PrimMismatch p)) a
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept (PrimMismatch p -> NonEmpty (PrimMismatch p)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimMismatch p -> NonEmpty (PrimMismatch p))
-> (Problem p -> PrimMismatch p)
-> Problem p
-> NonEmpty (PrimMismatch p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Problem p -> PrimMismatch p
forall p. Text -> Problem p -> PrimMismatch p
PrimMismatch (PrimValueSpec a -> Text
forall a. PrimValueSpec a -> Text
describeSpec PrimValueSpec a
prim))
(Value p -> PrimValueSpec a -> Except (Problem p) a
forall p a. Value p -> PrimValueSpec a -> Except (Problem p) a
getValue2 Value p
v PrimValueSpec a
prim)
getValue2 :: Value p -> PrimValueSpec a -> Except (Problem p) a
getValue2 :: forall p a. Value p -> PrimValueSpec a -> Except (Problem p) a
getValue2 (Text p
_ Text
t) PrimValueSpec a
TextSpec = a -> ExceptT (Problem p) Identity a
forall a. a -> ExceptT (Problem p) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Text
t
getValue2 (Number p
_ Number
n) PrimValueSpec a
NumberSpec = a -> ExceptT (Problem p) Identity a
forall a. a -> ExceptT (Problem p) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Number
n
getValue2 (List p
_ [Value p]
xs) (ListSpec ValueSpec a1
w) = ValueSpec a1 -> [Value p] -> Except (Problem p) [a1]
forall a p. ValueSpec a -> [Value p] -> Except (Problem p) [a]
getList ValueSpec a1
w [Value p]
xs
getValue2 (Atom p
_ Atom
b) PrimValueSpec a
AtomSpec = a -> ExceptT (Problem p) Identity a
forall a. a -> ExceptT (Problem p) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom -> Text
atomName Atom
b)
getValue2 Value p
v (ExactSpec Value ()
w)
| (() () -> Value p -> Value ()
forall a b. a -> Value b -> Value a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Value p
v) Value () -> Value () -> Bool
forall a. Eq a => a -> a -> Bool
== Value ()
w = a -> ExceptT (Problem p) Identity a
forall a. a -> ExceptT (Problem p) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = Problem p -> ExceptT (Problem p) Identity a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Problem p
forall p. Problem p
WrongExact
getValue2 (Sections p
_ [Section p]
s) (SectionsSpec Text
_ SectionsSpec a
w) = SectionsSpec a -> [Section p] -> ExceptT (Problem p) Identity a
forall a p. SectionsSpec a -> [Section p] -> Except (Problem p) a
getSections SectionsSpec a
w [Section p]
s
getValue2 (Sections p
_ [Section p]
s) (AssocSpec ValueSpec a1
w) = ValueSpec a1 -> [Section p] -> Except (Problem p) [(Text, a1)]
forall a p.
ValueSpec a -> [Section p] -> Except (Problem p) [(Text, a)]
getAssoc ValueSpec a1
w [Section p]
s
getValue2 Value p
v (NamedSpec Text
_ ValueSpec a
w) = (ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> ExceptT (Problem p) Identity a
forall p a.
(ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> Except (Problem p) a
getValue' ValueSpecMismatch p -> Problem p
forall p. ValueSpecMismatch p -> Problem p
NestedProblem ValueSpec a
w Value p
v
getValue2 Value p
v (CustomSpec Text
_ ValueSpec (Either Text a)
w) = ValueSpec (Either Text a)
-> Value p -> ExceptT (Problem p) Identity a
forall a p.
ValueSpec (Either Text a) -> Value p -> Except (Problem p) a
getCustom ValueSpec (Either Text a)
w Value p
v
getValue2 Value p
_ PrimValueSpec a
_ = Problem p -> ExceptT (Problem p) Identity a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Problem p
forall p. Problem p
TypeMismatch
getList :: ValueSpec a -> [Value p] -> Except (Problem p) [a]
getList :: forall a p. ValueSpec a -> [Value p] -> Except (Problem p) [a]
getList ValueSpec a
w = (Int -> Value p -> ExceptT (Problem p) Identity a)
-> [Int] -> [Value p] -> ExceptT (Problem p) Identity [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
i -> (ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> ExceptT (Problem p) Identity a
forall p a.
(ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> Except (Problem p) a
getValue' (Int -> ValueSpecMismatch p -> Problem p
forall p. Int -> ValueSpecMismatch p -> Problem p
ListElementProblem Int
i) ValueSpec a
w) [Int
1::Int ..]
getAssoc :: ValueSpec a -> [Section p] -> Except (Problem p) [(Text,a)]
getAssoc :: forall a p.
ValueSpec a -> [Section p] -> Except (Problem p) [(Text, a)]
getAssoc ValueSpec a
w = (Section p -> ExceptT (Problem p) Identity (Text, a))
-> [Section p] -> ExceptT (Problem p) Identity [(Text, a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Section p -> ExceptT (Problem p) Identity (Text, a))
-> [Section p] -> ExceptT (Problem p) Identity [(Text, a)])
-> (Section p -> ExceptT (Problem p) Identity (Text, a))
-> [Section p]
-> ExceptT (Problem p) Identity [(Text, a)]
forall a b. (a -> b) -> a -> b
$ \(Section p
_ Text
k Value p
v) ->
(,) Text
k (a -> (Text, a))
-> ExceptT (Problem p) Identity a
-> ExceptT (Problem p) Identity (Text, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> ExceptT (Problem p) Identity a
forall p a.
(ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> Except (Problem p) a
getValue' (Text -> ValueSpecMismatch p -> Problem p
forall p. Text -> ValueSpecMismatch p -> Problem p
SubkeyProblem Text
k) ValueSpec a
w Value p
v
getCustom ::
ValueSpec (Either Text a) ->
Value p ->
Except (Problem p) a
getCustom :: forall a p.
ValueSpec (Either Text a) -> Value p -> Except (Problem p) a
getCustom ValueSpec (Either Text a)
w Value p
v = (Text -> ExceptT (Problem p) Identity a)
-> (a -> ExceptT (Problem p) Identity a)
-> Either Text a
-> ExceptT (Problem p) Identity a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Problem p -> ExceptT (Problem p) Identity a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Problem p -> ExceptT (Problem p) Identity a)
-> (Text -> Problem p) -> Text -> ExceptT (Problem p) Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Problem p
forall p. Text -> Problem p
CustomProblem) a -> ExceptT (Problem p) Identity a
forall a. a -> ExceptT (Problem p) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> ExceptT (Problem p) Identity a)
-> ExceptT (Problem p) Identity (Either Text a)
-> ExceptT (Problem p) Identity a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ValueSpecMismatch p -> Problem p)
-> ValueSpec (Either Text a)
-> Value p
-> ExceptT (Problem p) Identity (Either Text a)
forall p a.
(ValueSpecMismatch p -> Problem p)
-> ValueSpec a -> Value p -> Except (Problem p) a
getValue' ValueSpecMismatch p -> Problem p
forall p. ValueSpecMismatch p -> Problem p
NestedProblem ValueSpec (Either Text a)
w Value p
v
lookupSection ::
Text ->
[Section p] ->
(Maybe (Value p), [Section p])
lookupSection :: forall p. Text -> [Section p] -> (Maybe (Value p), [Section p])
lookupSection Text
_ [] = (Maybe (Value p)
forall a. Maybe a
Nothing, [])
lookupSection Text
key (s :: Section p
s@(Section p
_ Text
k Value p
v):[Section p]
xs)
| Text
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
k = (Value p -> Maybe (Value p)
forall a. a -> Maybe a
Just Value p
v, [Section p]
xs)
| Bool
otherwise = case Text -> [Section p] -> (Maybe (Value p), [Section p])
forall p. Text -> [Section p] -> (Maybe (Value p), [Section p])
lookupSection Text
key [Section p]
xs of
(Maybe (Value p)
res, [Section p]
xs') -> (Maybe (Value p)
res, Section p
sSection p -> [Section p] -> [Section p]
forall a. a -> [a] -> [a]
:[Section p]
xs')