{-# LANGUAGE PolyKinds, DataKinds, KindSignatures,
ExplicitForAll, TemplateHaskell, ViewPatterns,
ScopedTypeVariables, TypeOperators, TypeFamilies,
GeneralizedNewtypeDeriving #-}
module Data.Yaml.Combinators
( Parser
, parse
, runParser
, string
, theString
, number
, integer
, bool
, null_
, array
, theArray
, ElementParser
, element
, object
, FieldParser
, field
, optField
, defaultField
, theField
, 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.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 <- 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
(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)
)
anyValue :: Parser Value
anyValue = Parser $ hpure $ ParserComponent . Just $ \val _np -> pure val
liftR :: f a -> ReaderT r f a
liftR = ReaderT . const