    {-# 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 :: 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)

    -- | 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 :: forall a. ValueSpec a -> FilePath -> IO a
    loadValueFromFile ValueSpec a
    spec FilePath
    path =
      do txt <- FilePath -> IO Text
    Text.readFile FilePath
    path
         let 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. (HasCallStack, 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
         val <- exceptIO (parse txt)
         exceptIO (loadValue spec 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 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)
         lift $ case 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 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)
         lift (traverse (getValue' (SubkeyProblem k) w) 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,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 NonEmpty.nonEmpty leftovers of
           Maybe (NonEmpty (Section p))
    Nothing -> a -> ExceptT (Problem p) Identity 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 -> ExceptT (Problem p) Identity 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)

    -- | 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' :: 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)

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

    -- | 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 :: 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 ..]

    -- | 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 :: 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

    -- | 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 :: 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

    -- | 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 :: 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')