module Data.Yaml.Combinators
( Parser
, parse
, runParser
, string
, theString
, number
, integer
, bool
, null_
, array
, theArray
, ElementParser
, element
, object
, FieldParser
, field
, optField
, defaultField
, theField
, ParseError(..)
, ppParseError
, Reason(..)
, validate
) where
import Data.Aeson (Value(..), Object, Array)
import Data.Scientific
import Data.Yaml (decodeEither, encode)
import Data.Text (Text)
import Data.List
import Data.Maybe
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import qualified Data.ByteString.Char8 as BS8
import Data.Bifunctor (first)
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State as State
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Functor.Product
import Data.Functor.Constant
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import Data.Ord
import Generics.SOP
import Generics.SOP.TH
deriveGeneric ''Value
parse :: Parser a -> ByteString -> Either String a
parse p bs = do
aesonValue <- decodeEither bs
first ppParseError $ runParser p aesonValue
data ParseError = ParseError
!Int
Reason
deriving (Eq, Show)
data Reason
= UnexpectedAsPartOf Value Value
| ExpectedAsPartOf (HashSet String) Value
| ExpectedInsteadOf (HashSet String) Value
deriving (Eq, Show)
compareSeverity :: ParseError -> ParseError -> Ordering
compareSeverity (ParseError l1 r1) (ParseError l2 r2) =
comparing (not . isUnexpected) r1 r2 <>
compare l1 l2 <>
comparing isMismatch r1 r2
where
isUnexpected e = case e of
UnexpectedAsPartOf {} -> True
_ -> False
isMismatch e = case e of
ExpectedInsteadOf {} -> True
_ -> False
moreSevere :: ParseError -> ParseError -> ParseError
moreSevere e1 e2 =
case compareSeverity e1 e2 of
LT -> e2
_ -> e1
lessSevere :: ParseError -> ParseError -> ParseError
lessSevere e1 e2 =
case compareSeverity e1 e2 of
GT -> e2
_ -> e1
newtype Validation a = Validation { getValidation :: Either ParseError a }
deriving Functor
instance Applicative Validation where
pure = Validation . Right
Validation a <*> Validation b = Validation $
case a of
Right va -> fmap va b
Left ea -> either (Left . moreSevere ea) (const $ Left ea) b
bindV :: Validation a -> (a -> Validation b) -> Validation b
bindV a b = Validation $ getValidation a >>= getValidation . b
mergeParseError :: ParseError -> ParseError -> ParseError
mergeParseError e1@(ParseError l1 r1) e2@(ParseError l2 r2)
| l1 == l2
, ExpectedAsPartOf exp1 w1 <- r1
, ExpectedAsPartOf exp2 w2 <- r2
, w1 == w2
= ParseError l1 (ExpectedAsPartOf (exp1 <> exp2) w1)
| l1 == l2
, ExpectedInsteadOf exp1 w1 <- r1
, ExpectedInsteadOf exp2 w2 <- r2
, w1 == w2
= ParseError l1 (ExpectedInsteadOf (exp1 <> exp2) w1)
| otherwise = lessSevere e1 e2
ppParseError :: ParseError -> String
ppParseError (ParseError _lvl reason) =
case reason of
UnexpectedAsPartOf part whole ->
"Unexpected \n\n" ++ showYaml part ++ "\nas part of\n\n" ++ showYaml whole
ExpectedInsteadOf exp1 got ->
"Expected " ++ fmt_list exp1 ++ " instead of:\n\n" ++ showYaml got
ExpectedAsPartOf exp1 got ->
"Expected " ++ fmt_list exp1 ++ " as part of:\n\n" ++ showYaml got
where
showYaml :: Value -> String
showYaml = BS8.unpack . encode
fmt_list :: HashSet String -> String
fmt_list = intercalate ", " . sort . HS.toList
newtype ParserComponent a fs = ParserComponent (Maybe (Value -> NP I fs -> Validation a))
newtype Parser a = Parser (NP (ParserComponent a) (Code Value))
pcFmap :: (a -> b) -> ParserComponent a fs -> ParserComponent b fs
pcFmap f (ParserComponent mbP) = ParserComponent $ (fmap . fmap . fmap . fmap $ f) mbP
instance Functor Parser where
fmap f (Parser comps) = Parser $ hliftA (pcFmap f) comps
instance Monoid (ParserComponent a fs) where
mempty = ParserComponent Nothing
ParserComponent mbP1 `mappend` ParserComponent mbP2 =
ParserComponent $ case (mbP1, mbP2) of
(Nothing, Nothing) -> Nothing
(Just p1, Nothing) -> Just p1
(Nothing, Just p2) -> Just p2
(Just p1, Just p2) -> Just $ \o v -> Validation $
case (getValidation $ p1 o v, getValidation $ p2 o v) of
(Right r1, _) -> Right r1
(_, Right r2) -> Right r2
(Left l1, Left l2) -> Left $ mergeParseError l1 l2
instance Monoid (Parser a) where
mempty = Parser $ hpure mempty
Parser rec1 `mappend` Parser rec2 = Parser $ hliftA2 mappend rec1 rec2
runParser :: Parser a -> Value -> Either ParseError a
runParser p = getValidation . runParserV p
runParserV :: Parser a -> Value -> Validation a
runParserV (Parser comps) orig@(from -> SOP v) =
hcollapse $ hliftA2 match comps v
where
match :: ParserComponent a fs -> NP I fs -> K (Validation a) fs
match (ParserComponent mbP) v1 = K $
case mbP of
Nothing -> Validation . Left $ ParseError 0 $ ExpectedInsteadOf (HS.singleton expected) orig
Just p -> p orig v1
expected =
let
f (ParserComponent pc) (K name) = K (name <$ pc)
in intercalate ", " . catMaybes . hcollapse $ hliftA2 f comps valueConNames
valueConNames :: NP (K String) (Code Value)
valueConNames =
let
ADT _ _ cons = datatypeInfo (Proxy :: Proxy Value)
in hliftA (\(Constructor name) -> K name) cons
fromComponent :: forall a . NS (ParserComponent a) (Code Value) -> Parser a
fromComponent parser = Parser $ hexpand mempty parser
decorate :: forall a b. Parser a -> (a -> Value -> Either ParseError b) -> Parser b
decorate (Parser components) decorator = Parser $ hmap wrap components
where
wrap :: ParserComponent a fs -> ParserComponent b fs
wrap (ParserComponent maybeP) = ParserComponent $
case maybeP of
Nothing -> Nothing
Just p -> Just $ \orig val -> p orig val `bindV`
\parsed -> Validation $ decorator parsed orig
incErrLevel :: Validation a -> Validation a
incErrLevel = Validation . first (\(ParseError l r) -> ParseError (l+1) r) . getValidation
string :: Parser Text
string = fromComponent $ S . S . Z $ ParserComponent $ Just $ const $ \(I s :* Nil) -> pure s
theString :: Text -> Parser ()
theString t = fromComponent $ S . S . Z $ ParserComponent $ Just $ const $ \(I s :* Nil) ->
Validation $ if s == t
then Right ()
else Left $ ParseError 0 (ExpectedInsteadOf (HS.singleton $ show t) (String s))
array :: Parser a -> Parser (Vector a)
array p = fromComponent $ S . Z $ ParserComponent $ Just $ const $ \(I a :* Nil) -> incErrLevel $ traverse (runParserV p) a
newtype ElementParser a = ElementParser
(((State [Value]) :.: (ReaderT Array Validation)) a)
deriving (Functor, Applicative)
element :: Parser a -> ElementParser a
element p = ElementParser $ Comp $ do
vs <- State.get
case vs of
[] -> return $ ReaderT $ \arr -> Validation . Left $
let n = V.length arr + 1
in ParseError 0 $ ExpectedAsPartOf (HS.singleton $ "at least " ++ show n ++ " elements") $ Array arr
(v:vs') -> do
State.put vs'
return . liftR $ runParserV p v
theArray :: ElementParser a -> Parser a
theArray (ElementParser (Comp ep)) = fromComponent $ S . Z $ ParserComponent $ Just $ const $ \(I a :* Nil) -> incErrLevel $
case first (flip runReaderT a) $ runState ep (V.toList a) of
(result, leftover) ->
result <*
(case leftover of
[] -> pure ()
v : _ -> Validation . Left $ ParseError 0 $ UnexpectedAsPartOf v $ Array a
)
number :: Parser Scientific
number = fromComponent $ S . S . S . Z $ ParserComponent $ Just $ const $ \(I n :* Nil) -> pure n
integer :: (Integral i, Bounded i) => Parser i
integer = fromComponent $ S . S . S . Z $ ParserComponent $ Just $ const $ \(I n :* Nil) ->
case toBoundedInteger n of
Just i -> pure i
Nothing -> Validation . Left $ ParseError 0 $ ExpectedInsteadOf (HS.singleton "integer") (Number n)
bool :: Parser Bool
bool = fromComponent $ S . S . S . S . Z $ ParserComponent $ Just $ const $ \(I b :* Nil) -> pure b
null_ :: Parser ()
null_ = fromComponent $ S . S . S . S . S . Z $ ParserComponent $ Just $ const $ \Nil -> pure ()
validate ::
Parser a
-> (a -> Either String b)
-> Parser b
validate parser validator =
decorate parser (validity . validator)
where
validity (Right result) _ = Right result
validity (Left problem) orig = Left $ ParseError 1 $ ExpectedInsteadOf (HS.singleton problem) orig
newtype FieldParser a = FieldParser
(Product
(ReaderT Object Validation)
(Constant (HashMap Text ())) a)
deriving (Functor, Applicative)
field
:: Text
-> Parser a
-> FieldParser a
field name p = FieldParser $
Pair
(ReaderT $ \o ->
case HM.lookup name o of
Nothing -> Validation . Left $ ParseError 0 $ ExpectedAsPartOf (HS.singleton $ "field " ++ show name) $ Object o
Just v -> runParserV p v
)
(Constant $ HM.singleton name ())
optField
:: Text
-> Parser a
-> FieldParser (Maybe a)
optField name p = FieldParser $
Pair
(ReaderT $ \o -> traverse (runParserV p) $ HM.lookup name o)
(Constant $ HM.singleton name ())
defaultField
:: Text
-> a
-> Parser a
-> FieldParser a
defaultField name defaultVal p = fromMaybe defaultVal <$> optField name p
theField
:: Text
-> Text
-> FieldParser ()
theField key value = field key (theString value)
object :: FieldParser a -> Parser a
object (FieldParser (Pair (ReaderT parseFn) (Constant names))) = fromComponent $ Z $ ParserComponent $ Just $ const $ \(I o :* Nil) ->
incErrLevel $
parseFn o <*
(case HM.keys (HM.difference o names) of
[] -> pure ()
name : _ ->
let v = o HM.! name
in Validation . Left $ ParseError 0 $ UnexpectedAsPartOf (Object (HM.singleton name v)) (Object o)
)
liftR :: f a -> ReaderT r f a
liftR = ReaderT . const