{-# 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 :: 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 :: ValueSpec a -> FilePath -> IO a
loadValueFromFile ValueSpec a
spec FilePath
path =
do Text
txt <- FilePath -> IO Text
Text.readFile FilePath
path
let exceptIO :: Either e a -> IO a
exceptIO Either e a
m = (e -> IO a) -> (a -> IO a) -> Either e a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either e a
m
Value Position
val <- Either ParseError (Value Position) -> IO (Value Position)
forall e a. Exception e => Either e a -> IO a
exceptIO (Text -> Either ParseError (Value Position)
parse Text
txt)
Either (ValueSpecMismatch Position) a -> IO a
forall e a. Exception e => Either e 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 :: 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)
ExceptT (Problem p) Identity a
-> StateT [Section p] (Except (Problem p)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Problem p) Identity a
-> StateT [Section p] (Except (Problem p)) a)
-> ExceptT (Problem p) Identity 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 -> 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
Maybe (Value p)
Nothing -> Problem p -> ExceptT (Problem p) Identity 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 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)
ExceptT (Problem p) Identity (Maybe a)
-> StateT [Section p] (Except (Problem p)) (Maybe a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Value p -> ExceptT (Problem p) Identity a)
-> Maybe (Value p) -> ExceptT (Problem p) Identity (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((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) Maybe (Value p)
mb)
getSections :: SectionsSpec a -> [Section p] -> Except (Problem p) a
getSections :: 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 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 (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 (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 :: 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' :: (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 :: 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 (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 :: Value p -> PrimValueSpec a -> Except (Problem p) a
getValue2 (Text p
_ Text
t) PrimValueSpec a
TextSpec = Text -> ExceptT (Problem p) Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
getValue2 (Number p
_ Number
n) PrimValueSpec a
NumberSpec = Number -> ExceptT (Problem p) Identity Number
forall (f :: * -> *) a. Applicative f => a -> f a
pure Number
n
getValue2 (List p
_ [Value p]
xs) (ListSpec ValueSpec a
w) = ValueSpec a -> [Value p] -> Except (Problem p) [a]
forall a p. ValueSpec a -> [Value p] -> Except (Problem p) [a]
getList ValueSpec a
w [Value p]
xs
getValue2 (Atom p
_ Atom
b) PrimValueSpec a
AtomSpec = Text -> ExceptT (Problem p) Identity Text
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 (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 = () -> ExceptT (Problem p) Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = Problem p -> Except (Problem p) 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] -> Except (Problem p) 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 a
w) = ValueSpec a -> [Section p] -> Except (Problem p) [(Text, a)]
forall a p.
ValueSpec a -> [Section p] -> Except (Problem p) [(Text, a)]
getAssoc ValueSpec a
w [Section p]
s
getValue2 Value p
v (NamedSpec Text
_ ValueSpec a
w) = (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' 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 -> Except (Problem p) 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 -> Except (Problem p) 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 :: ValueSpec a -> [Value p] -> Except (Problem p) [a]
getList ValueSpec a
w = (Int -> Value p -> ExceptT (Problem p) Identity a)
-> [Int] -> [Value p] -> Except (Problem p) [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 :: ValueSpec a -> [Section p] -> Except (Problem p) [(Text, a)]
getAssoc ValueSpec a
w = (Section p -> ExceptT (Problem p) Identity (Text, a))
-> [Section p] -> Except (Problem p) [(Text, a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Section p -> ExceptT (Problem p) Identity (Text, a))
-> [Section p] -> Except (Problem p) [(Text, a)])
-> (Section p -> ExceptT (Problem p) Identity (Text, a))
-> [Section p]
-> Except (Problem p) [(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 :: ValueSpec (Either Text a) -> Value p -> Except (Problem p) a
getCustom ValueSpec (Either Text a)
w Value p
v = (Text -> Except (Problem p) a)
-> (a -> Except (Problem p) a)
-> Either Text a
-> Except (Problem p) a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Problem p -> Except (Problem p) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Problem p -> Except (Problem p) a)
-> (Text -> Problem p) -> Text -> Except (Problem p) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Problem p
forall p. Text -> Problem p
CustomProblem) a -> Except (Problem p) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> Except (Problem p) a)
-> ExceptT (Problem p) Identity (Either Text a)
-> Except (Problem p) 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 :: 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')