{-# LANGUAGE PolyKinds, DataKinds, KindSignatures,
ExplicitForAll, TemplateHaskell, ViewPatterns,
ScopedTypeVariables, TypeOperators, TypeFamilies,
GeneralizedNewtypeDeriving, GADTs, LambdaCase #-}
module Data.Yaml.Combinators
( Parser
, parse
, runParser
, string
, theString
, number
, integer
, bool
, null_
, array
, theArray
, ElementParser
, element
, object
, FieldParser
, field
, optField
, defaultField
, theField
, extraFields
, anyValue
, 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 qualified Data.ByteString.Char8 as BS8
import Data.Bifunctor (first)
import Control.Monad
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State as State
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as HM
import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import Data.Ord
import Data.Monoid
import Generics.SOP
import Generics.SOP.TH
import Data.Yaml.Combinators.Free as Free
deriveGeneric ''Value
parse :: Parser a -> ByteString -> Either String a
parse p bs = do
aesonValue <- first show $ 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 Semigroup (ParserComponent a fs) where
ParserComponent mbP1 <> 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 (ParserComponent a fs) where
mempty = ParserComponent Nothing
mappend = (<>)
instance Semigroup (Parser a) where
Parser rec1 <> Parser rec2 = Parser $ hliftA2 mappend rec1 rec2
instance Monoid (Parser a) where
mempty = Parser $ hpure mempty
mappend = (<>)
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
(Free FieldParserBase a)
deriving (Functor, Applicative)
data FieldParserBase a where
OneField
:: Text
-> ReaderT Object Validation a
-> FieldParserBase a
ExtraFields :: FieldParserBase Object
field
:: Text
-> Parser a
-> FieldParser a
field name p = FieldParser . Free.lift . OneField name $
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
optField
:: Text
-> Parser a
-> FieldParser (Maybe a)
optField name p = FieldParser . Free.lift . OneField name $
ReaderT $ \o -> traverse (runParserV p) $ HM.lookup name o
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)
extraFields :: FieldParser Object
extraFields = FieldParser . Free.lift $ ExtraFields
data StrictPair a b = StrictPair !a !b
instance (Semigroup a, Semigroup b) => Semigroup (StrictPair a b) where
StrictPair a1 b1 <> StrictPair a2 b2 = StrictPair (a1 <> a2) (b1 <> b2)
instance (Monoid a, Monoid b) => Monoid (StrictPair a b) where
mempty = StrictPair mempty mempty
object :: FieldParser a -> Parser a
object (FieldParser fp) = fromComponent $ Z $ ParserComponent $ Just $ const $ \(I o :* Nil) ->
incErrLevel $
let
StrictPair requested_names (Any requested_extra_fields) = Free.foldMap (\case
OneField name _ -> StrictPair (HM.singleton name ()) (Any False)
ExtraFields -> StrictPair mempty (Any True)
) fp
extra_fields = HM.difference o requested_names
extra_fields_error =
when (not requested_extra_fields && not (HM.null extra_fields)) $
Validation . Left $ ParseError 0 $
UnexpectedAsPartOf (Object extra_fields) (Object o)
in
Free.run (\case
OneField _ p -> runReaderT p o
ExtraFields -> pure extra_fields
) fp
<* extra_fields_error
anyValue :: Parser Value
anyValue = Parser $ hpure $ ParserComponent . Just $ \val _np -> pure val
liftR :: f a -> ReaderT r f a
liftR = ReaderT . const