module Config.Schema.Load
( loadValue
, LoadError(..)
, Problem(..)
) where
import Control.Monad (zipWithM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT(..), runStateT)
import Control.Monad.Trans.Except (Except, runExcept, throwE)
import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, local)
import Data.Semigroup.Foldable (asum1)
import Data.Functor.Alt (Alt((<!>)))
import Data.Monoid ((<>))
import Data.Ratio (numerator, denominator)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as Text
import Config
import Config.Schema.Spec
loadValue ::
ValueSpecs a ->
Value Position ->
Either (NonEmpty LoadError) a
loadValue spec val = runLoad (getValue spec val)
getSection :: Position -> SectionSpec a -> StateT [Section Position] Load a
getSection pos (ReqSection k _ w) =
do v <- StateT (lookupSection pos k)
lift (scope k (getValue w v))
getSection pos (OptSection k _ w) =
do mb <- optional1 (StateT (lookupSection pos k))
lift (traverse (scope k . getValue w) mb)
getSections :: Position -> SectionSpecs a -> [Section Position] -> Load a
getSections pos spec xs =
do (a,leftovers) <- runStateT (runSections (getSection pos) spec) xs
case NonEmpty.nonEmpty leftovers of
Nothing -> return a
Just ss -> asum1 (fmap (\s -> loadFail (sectionAnn s) (UnusedSection (sectionName s))) ss)
getValue :: ValueSpecs a -> Value Position -> Load a
getValue s v = runValueSpecs (getValue1 v) s
getValue1 :: Value Position -> ValueSpec a -> Load a
getValue1 (Text _ t) TextSpec = pure t
getValue1 (Number _ _ n) IntegerSpec = pure n
getValue1 (Floating _ a b) IntegerSpec | Just i <- floatingToInteger a b = pure i
getValue1 (Number _ _ n) RationalSpec = pure (fromInteger n)
getValue1 (Floating _ a b) RationalSpec = pure (floatingToRational a b)
getValue1 (List _ xs) (ListSpec w) = getList w xs
getValue1 (Atom _ b) AnyAtomSpec = pure (atomName b)
getValue1 (Atom _ b) (AtomSpec a) | a == atomName b = pure ()
getValue1 (Sections p s) (SectionSpecs _ w) = getSections p w s
getValue1 (Sections _ s) (AssocSpec w) = getAssoc w s
getValue1 v (NamedSpec _ w) = getValue w v
getValue1 v (CustomSpec l w) = getCustom l w v
getValue1 v TextSpec = loadFail (valueAnn v) (SpecMismatch "text")
getValue1 v IntegerSpec = loadFail (valueAnn v) (SpecMismatch "integer")
getValue1 v RationalSpec = loadFail (valueAnn v) (SpecMismatch "number")
getValue1 v ListSpec{} = loadFail (valueAnn v) (SpecMismatch "list")
getValue1 v AnyAtomSpec = loadFail (valueAnn v) (SpecMismatch "atom")
getValue1 v (AtomSpec a) = loadFail (valueAnn v) (SpecMismatch ("`" <> a <> "`"))
getValue1 v (SectionSpecs l _) = loadFail (valueAnn v) (SpecMismatch l)
getValue1 v AssocSpec{} = loadFail (valueAnn v) (SpecMismatch "association list")
getList :: ValueSpecs a -> [Value Position] -> Load [a]
getList w = zipWithM (\i x -> scope (Text.pack (show i)) (getValue w x)) [1::Int ..]
getAssoc :: ValueSpecs a -> [Section Position] -> Load [(Text,a)]
getAssoc w = traverse $ \(Section _ k v) -> (,) k <$> getValue w v
getCustom ::
Text ->
ValueSpecs (Maybe a) ->
Value Position ->
Load a
getCustom l w v =
do x <- getValue w v
case x of
Nothing -> loadFail (valueAnn v) (SpecMismatch l)
Just y -> pure y
lookupSection ::
Position ->
Text ->
[Section p] ->
Load (Value p, [Section p])
lookupSection pos key [] = loadFail pos (MissingSection key)
lookupSection pos key (s@(Section _ k v):xs)
| key == k = pure (v, xs)
| otherwise = do (v',xs') <- lookupSection pos key xs
return (v',s:xs')
floatingToRational :: Integer -> Integer -> Rational
floatingToRational x y = fromInteger x * 10^^y
floatingToInteger :: Integer -> Integer -> Maybe Integer
floatingToInteger x y
| denominator r == 1 = Just (numerator r)
| otherwise = Nothing
where r = floatingToRational x y
newtype Load a = MkLoad { unLoad :: ReaderT [Text] (Except (NonEmpty LoadError)) a }
deriving (Functor, Applicative, Monad)
instance Alt Load where MkLoad x <!> MkLoad y = MkLoad (x <!> y)
data LoadError = LoadError Position [Text] Problem
deriving (Read, Show)
runLoad :: Load a -> Either (NonEmpty LoadError) a
runLoad = runExcept . flip runReaderT [] . unLoad
data Problem
= MissingSection Text
| UnusedSection Text
| SpecMismatch Text
deriving (Eq, Ord, Read, Show)
scope :: Text -> Load a -> Load a
scope key (MkLoad m) = MkLoad (local (key:) m)
loadFail :: Position -> Problem -> Load a
loadFail pos cause = MkLoad $
do path <- ask
lift (throwE (pure (LoadError pos (reverse path) cause)))
optional1 :: (Applicative f, Alt f) => f a -> f (Maybe a)
optional1 fa = Just <$> fa <!> pure Nothing