{-# Language OverloadedStrings, GeneralizedNewtypeDeriving, GADTs #-}
module Config.Schema.Load
( loadValue
, loadValueFromFile
, SchemaError(..)
, LoadError(..)
, Problem(..)
) where
import Control.Exception (Exception(..), throwIO)
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 qualified Data.Text.IO as Text
import Config
import Config.Schema.Spec
loadValue ::
ValueSpecs a ->
Value p ->
Either (NonEmpty (LoadError p)) a
loadValue spec val = runLoad (getValue spec val)
loadValueFromFile ::
ValueSpecs a ->
FilePath ->
IO a
loadValueFromFile spec path =
do txt <- Text.readFile path
val <- either throwIO return (parse txt)
either (throwIO . SchemaError) return (loadValue spec val)
newtype SchemaError = SchemaError (NonEmpty (LoadError Position))
deriving Show
instance Exception SchemaError where
displayException (SchemaError e) = foldr showLoadError "" e
where
showLoadError (LoadError pos path problem)
= shows (posLine pos)
. showChar ':'
. shows (posColumn pos)
. showString ": "
. foldr (\x xs -> showString (Text.unpack x) . showChar ':' . xs) id path
. showChar ' '
. showProblem problem
. showChar '\n'
showProblem p =
case p of
MissingSection x -> showString "missing required section `"
. showString (Text.unpack x) . showChar '`'
UnusedSection x -> showString "unused section `"
. showString (Text.unpack x) . showChar '`'
SpecMismatch x -> showString "expected " . showString (Text.unpack x)
getSection :: p -> SectionSpec a -> StateT [Section p] (Load p) 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 :: p -> SectionSpecs a -> [Section p] -> Load p 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 p -> Load p a
getValue s v = runValueSpecs (getValue1 v) s
getValue1 :: Value p -> ValueSpec a -> Load p 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 p] -> Load p [a]
getList w = zipWithM (\i x -> scope (Text.pack (show i)) (getValue w x)) [1::Int ..]
getAssoc :: ValueSpecs a -> [Section p] -> Load p [(Text,a)]
getAssoc w = traverse $ \(Section _ k v) -> (,) k <$> scope k (getValue w v)
getCustom ::
Text ->
ValueSpecs (Maybe a) ->
Value p ->
Load p a
getCustom l w v =
do x <- getValue w v
case x of
Nothing -> loadFail (valueAnn v) (SpecMismatch l)
Just y -> pure y
lookupSection ::
p ->
Text ->
[Section p] ->
Load p (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 p a = MkLoad { unLoad :: ReaderT [Text] (Except (NonEmpty (LoadError p))) a }
deriving (Functor, Applicative, Monad)
instance Alt (Load p) where MkLoad x <!> MkLoad y = MkLoad (x <!> y)
data LoadError p = LoadError p [Text] Problem
deriving (Read, Show)
runLoad :: Load p a -> Either (NonEmpty (LoadError p)) a
runLoad = runExcept . flip runReaderT [] . unLoad
data Problem
= MissingSection Text
| UnusedSection Text
| SpecMismatch Text
deriving (Eq, Ord, Read, Show)
scope :: Text -> Load p a -> Load p a
scope key (MkLoad m) = MkLoad (local (key:) m)
loadFail :: p -> Problem -> Load p 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