{-# Language GADTs #-}
{-|
Module      : Config.Schema.Load
Description : Operations to extract a value from a configuration.
Copyright   : (c) Eric Mertens, 2017
License     : ISC
Maintainer  : emertens@gmail.com

This module automates the extraction of a decoded value from a configuration
value according to a specification as built using "Config.Schema.Spec".

-}
module Config.Schema.Load
  ( loadValue
  , loadValueFromFile

  -- * Errors
  , 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


-- | Match a 'Value' against a 'ValueSpec' and return either
-- the interpretation of that value or the list of errors
-- encountered.
loadValue ::
  ValueSpec a                       {- ^ specification           -} ->
  Value p                           {- ^ value                   -} ->
  Either (ValueSpecMismatch p) a {- ^ errors or decoded value -}
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)


-- | Read a configuration file, parse it, and validate it according
-- to the given specification.
--
-- Throws 'IOError', 'ParseError', or 'ValueSpecMismatch'
loadValueFromFile ::
  ValueSpec a {- ^ specification -} ->
  FilePath    {- ^ filename      -} ->
  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)

-- | Match a 'Value' against a 'ValueSpec' given a wrapper for any nested
-- mismatch errors that might occur.
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)

-- | Match a primitive value specification against a single value.
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


-- | This operation processes all of the values in a list with the given
-- value specification and updates the scope with a one-based list index.
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 ..]


-- | This operation processes all of the values in a section list
-- against the given specification and associates them with the
-- section name.
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

-- | Match a value against its specification. If 'Just' is matched
-- return the value. If 'Nothing is matched, report an error.
getCustom ::
  ValueSpec (Either Text a) {- ^ specification -} ->
  Value p                   {- ^ value         -} ->
  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


-- | Extract a section from a list of sections by name.
lookupSection ::
  Text                         {- ^ section name                       -} ->
  [Section p]                  {- ^ available sections                 -} ->
  (Maybe (Value p), [Section p]) {- ^ found value and remaining sections -}
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')