{-# 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 spec :: ValueSpec a
spec val :: 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 spec :: ValueSpec a
spec path :: FilePath
path =
  do Text
txt <- FilePath -> IO Text
Text.readFile FilePath
path
     let exceptIO :: Either e a -> IO a
exceptIO m :: 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 k :: Text
k _ w :: 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 v :: 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
       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 k :: Text
k _ w :: 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 spec :: SectionsSpec a
spec xs :: [Section p]
xs =
  do (a :: a
a,leftovers :: [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
       Nothing -> a -> Except (Problem p) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
       Just ss :: 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 s :: ValueSpec a
s v :: 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' p :: ValueSpecMismatch p -> Problem p
p s :: ValueSpec a
s v :: 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 v :: Value p
v prim :: 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 _ t :: Text
t)       TextSpec           = Text -> ExceptT (Problem p) Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
getValue2 (Number _ n :: Number
n)     NumberSpec         = Number -> ExceptT (Problem p) Identity Number
forall (f :: * -> *) a. Applicative f => a -> f a
pure Number
n
getValue2 (List _ xs :: [Value p]
xs)      (ListSpec w :: 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 _ b :: Atom
b)       AnyAtomSpec        = Text -> ExceptT (Problem p) Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom -> Text
atomName Atom
b)
getValue2 (Atom _ b :: Atom
b)       (AtomSpec a :: Text
a)
  | Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Atom -> Text
atomName Atom
b = () -> 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
WrongAtom
getValue2 (Sections _ s :: [Section p]
s)   (SectionsSpec _ w :: 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 _ s :: [Section p]
s)   (AssocSpec w :: 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 v :: Value p
v                (NamedSpec _ w :: 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 v :: Value p
v                (CustomSpec _ w :: 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 _                _                  = 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 w :: 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 (\i :: 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) [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 w :: 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 _ k :: Text
k v :: 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 w :: ValueSpec (Either Text a)
w v :: 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 _ [] = (Maybe (Value p)
forall a. Maybe a
Nothing, [])
lookupSection key :: Text
key (s :: Section p
s@(Section _ k :: Text
k v :: Value p
v):xs :: [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
                  (res :: Maybe (Value p)
res, xs' :: [Section p]
xs') -> (Maybe (Value p)
res, Section p
sSection p -> [Section p] -> [Section p]
forall a. a -> [a] -> [a]
:[Section p]
xs')