yaml-combinators (empty) → 1.0

raw patch · 7 files changed

+538/−0 lines, 7 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, doctest, generics-sop, scientific, tasty, tasty-hunit, text, transformers, unordered-containers, vector, yaml, yaml-combinators

Files

• ChangeLog.md +5/−0
• LICENSE +21/−0
• Setup.hs +2/−0
• src/Data/Yaml/Combinators.hs +365/−0
• tests/doctests.hs +2/−0
• tests/test.hs +79/−0
• yaml-combinators.cabal +64/−0

@@ -0,0 +1,5 @@+# Revision history for yaml-combinators++## 1.0 — 2017-03-03++* First version. Released on an unsuspecting world.

@@ -0,0 +1,21 @@+Copyright (c) 2015 Signal Vine, LLC+Copyright (c) 2017 Roman Cheplyaka++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,365 @@+-- | Combinators for parsing YAML into Haskell types.+--+-- Based on the article <https://ro-che.info/articles/2015-07-26-better-yaml-parsing Better Yaml Parsing>.+{-# LANGUAGE PolyKinds, DataKinds, KindSignatures,+             ExplicitForAll, TemplateHaskell, ViewPatterns,+             TypeOperators, TypeFamilies,+             GeneralizedNewtypeDeriving #-}+module Data.Yaml.Combinators+  ( Parser+  , parse+  , runParser+  -- * Scalars+  , string+  , theString+  , number+  , integer+  , bool+  -- * Arrays+  , array+  , theArray+  , ElementParser+  , element+  -- * Objects+  , object+  , FieldParser+  , field+  , optField+  , theField+  -- * Errors+  , ParseError(..)+  , Reason(..)+  ) 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 Control.Monad.Trans.Class+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 Generics.SOP+import Generics.SOP.TH++-- $setup+-- >>> :set -XOverloadedStrings -XTypeApplications+-- >>> import Data.Monoid++deriveGeneric ''Value++----------------------------------------------------------------------+--                           Parsing function+----------------------------------------------------------------------++-- | Run a 'Parser' on a 'ByteString' containing the YAML content.+--+-- This is a high-level function implemented on top of 'runParser'.+parse :: Parser a -> ByteString -> Either String a+parse p bs = do+  aesonValue <- decodeEither bs+  first ppParseError $ runParser p aesonValue++----------------------------------------------------------------------+--                      Errors and Pretty-printing+----------------------------------------------------------------------++-- | A parse error. 'Reason' describes the error.+-- The 'Int' field denotes at which level the error occurred and+-- is used to select the deepest (most relevant) error+-- when merging multiple parsers.+data ParseError = ParseError+  !Int  -- level+  Reason+  deriving (Eq, Show)++-- | Describes what exactly went wrong during parsing.+data Reason+  = UnexpectedAsPartOf Value Value+  | ExpectedAsPartOf String Value+  | ExpectedInsteadOf String Value+  deriving (Eq, Show)++mergeParseError :: ParseError -> ParseError -> ParseError+mergeParseError e1@(ParseError l1 r1) e2@(ParseError l2 r2) =+  case compare l1 l2 of+    GT -> e1+    EQ+      | ExpectedAsPartOf exp1 w1 <- r1+      , ExpectedAsPartOf exp2 w2 <- r2+      , w1 == w2+      -> ParseError l1 (ExpectedAsPartOf (exp1 ++ ", " ++ exp2) w1)+      | ExpectedInsteadOf exp1 w1 <- r1+      , ExpectedInsteadOf exp2 w2 <- r2+      , w1 == w2+      -> ParseError l1 (ExpectedInsteadOf (exp1 ++ ", " ++ exp2) w1)+    _ -> 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 " ++ exp1 ++ " instead of:\n\n" ++ showYaml got+    ExpectedAsPartOf exp1 got ->+      "Expected " ++ exp1 ++ " as part of:\n\n" ++ showYaml got+  where+    showYaml :: Value -> String+    showYaml = BS8.unpack . encode++----------------------------------------------------------------------+--                           Core definitions+----------------------------------------------------------------------++newtype ParserComponent a fs = ParserComponent (Maybe (NP I fs -> Either ParseError a))+-- | A top-level YAML parser.+--+-- * Construct a 'Parser' with 'string', 'number', 'integer', 'bool', 'array', or 'object'.+--+-- * Combine two or more 'Parser's with 'Monoid' operators+-- such as 'mappend', 'Data.Monoid.<>', or `mconcat` —+-- e.g. if you expect either an object or a string.+--+-- * Run with 'parse' or 'runParser'.+newtype Parser a = Parser (NP (ParserComponent a) (Code Value))++-- fmap for ParserComponent (in its first type argument)+pcFmap :: (a -> b) -> ParserComponent a fs -> ParserComponent b fs+pcFmap f (ParserComponent mbP) = ParserComponent $ (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 $ \v ->+        case (p1 v, p2 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++-- | A low-level function to run a 'Parser'.+runParser :: Parser a -> Value -> Either ParseError a+runParser (Parser comps) orig@(from -> SOP v) =+  hcollapse $ hliftA2 match comps v+  where+    match :: ParserComponent a fs -> NP I fs -> K (Either ParseError a) fs+    match (ParserComponent mbP) v1 = K $+      case mbP of+        Nothing -> Left $ ParseError 0 $ ExpectedInsteadOf expected orig+        Just p -> p 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 $ hap' (hliftA (Fn . const) parser) (hpure mempty :: NP (ParserComponent a) (Code Value))++hap' :: forall f (xs :: [k]) . NS (f -.-> f) xs -> NP f xs -> NP f xs+hap' (Z (Fn f)) (h :* t) = f h :* t+hap' (S f) (h :* t) = h :* hap' f t++----------------------------------------------------------------------+--                           Combinators+----------------------------------------------------------------------++incErrLevel :: Either ParseError a -> Either ParseError a+incErrLevel = first $ \(ParseError l r) -> ParseError (l+1) r++-- | Match a single YAML string.+--+-- >>> parse string "howdy"+-- Right "howdy"+string :: Parser Text+string = fromComponent $ S . S . Z $ ParserComponent $ Just $ \(I s :* Nil) -> Right s++-- | Match a specific YAML string, usually a «tag» identifying a particular+-- form of an array or object.+--+-- >>> parse (theString "hello") "hello"+-- Right ()+-- >>> either putStr print $ parse (theString "hello") "bye"+-- Expected "hello" instead of:+-- <BLANKLINE>+-- bye+theString :: Text -> Parser ()+theString t = fromComponent $ S . S . Z $ ParserComponent $ Just $ \(I s :* Nil) ->+  if s == t+    then Right ()+    else Left $ ParseError 1 (ExpectedInsteadOf (show t) (String s))++-- | Match an array of elements, where each of elements are matched by+-- the same parser. This is the function you'll use most of the time when+-- parsing arrays, as they are usually homogeneous.+--+-- >>> parse (array string) "[a,b,c]"+-- Right ["a","b","c"]+array :: Parser a -> Parser (Vector a)+array p = fromComponent $ S . Z $ ParserComponent $ Just $ \(I a :* Nil) -> incErrLevel $ mapM (runParser p) a++-- | An 'ElementParser' describes how to parse a fixed-size array+-- where each positional element has its own parser.+--+-- This can be used to parse heterogeneous tuples represented as YAML+-- arrays.+--+-- * Construct an 'ElementParser' with 'element' and the 'Applicative' combinators.+--+-- * Turn a 'FieldParser' into a 'Parser' with 'theArray'.+newtype ElementParser a = ElementParser (StateT [Value] (Either (Array -> ParseError)) a)+  deriving (Functor, Applicative)++-- | Construct an 'ElementParser' that parses the current array element+-- with the given 'Parser'.+element :: Parser a -> ElementParser a+element p = ElementParser $ do+  vs <- State.get+  case vs of+    [] -> lift $ Left $ \arr ->+      let n = V.length arr + 1+      in ParseError 0 $ ExpectedAsPartOf ("at least " ++ show n ++ " elements") $ Array arr+    (v:vs') -> do+      State.put vs'+      lift $ first const $ incErrLevel $ runParser p v++-- | Match an array consisting of a fixed number of elements. The way each+-- element is parsed depends on its position within the array and+-- is determined by the 'ElementParser'.+--+-- >>> parse (theArray $ (,) <$> element string <*> element bool) "[f, true]"+-- Right ("f",True)+theArray :: ElementParser a -> Parser a+theArray (ElementParser ep) = fromComponent $ S . Z $ ParserComponent $ Just $ \(I a :* Nil) -> incErrLevel $+  case runStateT ep (V.toList a) of+    Right (r, []) -> return r+    Right (_, v:_) -> Left $ ParseError 0 $ UnexpectedAsPartOf v $ Array a+    Left errFn -> Left $ errFn a++-- | Match a real number.+--+-- >>> parse number "3.14159"+-- Right 3.14159+number :: Parser Scientific+number = fromComponent $ S . S . S . Z $ ParserComponent $ Just $ \(I n :* Nil) -> Right n++-- | Match an integer.+--+-- >>> parse (integer @Int) "2017"+-- Right 2017+integer :: (Integral i, Bounded i) => Parser i+integer = fromComponent $ S . S . S . Z $ ParserComponent $ Just $ \(I n :* Nil) ->+  case toBoundedInteger n of+    Just i -> Right i+    Nothing -> Left $ ParseError 0 $ ExpectedInsteadOf "integer" (Number n)++-- | Match a boolean.+--+-- >>> parse bool "yes"+-- Right True+bool :: Parser Bool+bool = fromComponent $ S . S . S . S . Z $ ParserComponent $ Just $ \(I b :* Nil) -> Right b++-- | A 'FieldParser' describes how to parse an object.+--+-- * Construct a 'FieldParser' with 'field', 'optField', or 'theField', and the 'Applicative' combinators.+--+-- * Turn a 'FieldParser' into a 'Parser' with 'object'.+newtype FieldParser a = FieldParser+  (Product+    (ReaderT Object (Either ParseError))+    (Constant (HashMap Text ())) a)+  deriving (Functor, Applicative)++-- | Require an object field with the given name and with a value matched by+-- the given 'Parser'.+field+  :: Text -- ^ field name+  -> Parser a -- ^ value parser+  -> FieldParser a+field name p = FieldParser $+  Pair+    (ReaderT $ \o ->+      case HM.lookup name o of+        Nothing -> Left $ ParseError 0 $ ExpectedAsPartOf ("field " ++ show name) $ Object o+        Just v -> incErrLevel $ runParser p v+    )+    (Constant $ HM.singleton name ())++-- | Declare an optional object field with the given name and with a value+-- matched by the given 'Parser'.+optField+  :: Text -- ^ field name+  -> Parser a -- ^ value parser+  -> FieldParser (Maybe a)+optField name p = FieldParser $+  Pair+    (ReaderT $ \o -> traverse (incErrLevel . runParser p) $ HM.lookup name o)+    (Constant $ HM.singleton name ())++-- | Require an object field with the given name and the given string value.+--+-- This is a convenient wrapper around 'theString' intended for «tagging»+-- objects.+--+-- >>> :{+--     let p = object (Right <$ theField "type" "number" <*> field "value" number)+--          <> object (Left  <$ theField "type" "string" <*> field "value" string)+-- >>> :}+--+-- >>> parse p "{type: string, value: abc}"+-- Right (Left "abc")+-- >>> parse p "{type: number, value: 123}"+-- Right (Right 123.0)+theField+  :: Text -- ^ key name+  -> Text -- ^ expected value+  -> FieldParser ()+theField key value = field key (theString value)++-- | Match an object. Which set of keys to expect and how their values+-- should be parsed is determined by the 'FieldParser'.+--+-- >>> let p = object $ (,) <$> field "name" string <*> optField "age" (integer @Int)+-- >>> parse p "{ name: Anton, age: 2 }"+-- Right ("Anton",Just 2)+-- >>> parse p "name: Roma"+-- Right ("Roma",Nothing)+object :: FieldParser a -> Parser a+object (FieldParser (Pair (ReaderT parseFn) (Constant names))) = fromComponent $ Z $ ParserComponent $ Just $ \(I o :* Nil) ->+  incErrLevel $+    parseFn o <*+    (case HM.keys (HM.difference o names) of+      [] -> pure ()+      name : _ ->+        let v = o HM.! name+        in Left $ ParseError 0 $ UnexpectedAsPartOf (Object (HM.singleton name v)) (Object o)+    )

@@ -0,0 +1,2 @@+import Test.DocTest+main = doctest ["-isrc", "src/Data/Yaml/Combinators.hs"]

@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+import Data.Yaml.Combinators+import Data.Functor+import Test.Tasty+import Test.Tasty.HUnit+import Data.Aeson hiding (object)+import Data.Monoid+import qualified Data.HashMap.Strict as HM++main = defaultMain tests++tests = testGroup "Data.Yaml.Combinators"+  [ testCase "Expect String, get String" $+      runParser string (String "hi") @?=+        Right "hi"+  , testCase "Expect String, get Number" $+      runParser string (Number 3) @?=+        Left (ParseError 0 $ ExpectedInsteadOf "String" (Number 3))+  , testCase "Expect specific String, get another String" $+      runParser (theString "bye") (String "hi") @?=+        Left (ParseError 1 $ ExpectedInsteadOf "\"bye\"" (String "hi"))+  , testCase "Expect specific String or Number, get another string" $+      runParser (theString "bye" <> void number) (String "hi") @?=+        Left (ParseError 1 $ ExpectedInsteadOf "\"bye\"" (String "hi"))+  , testCase "Expect an array, get an array" $+      runParser (array string) (Array [String "hi"]) @?=+        Right ["hi"]+  , testCase "Expect an array, get an object" $+      runParser (array string) (Object HM.empty) @?=+        Left (ParseError 0 $ ExpectedInsteadOf "Array" (Object []))+  , testCase "Expect an array of Strings, get an array of Numbers" $+      runParser (array string) (Array [Number 3]) @?=+        Left (ParseError 1 $ ExpectedInsteadOf "String" (Number 3))+  , testCase "Expect an object, get an object" $+      runParser (object $ field "foo" number) (Object [("foo", Number 1)]) @?=+        Right 1+  , testCase "Expect an object, get an array" $+      runParser (object $ field "foo" number) (Array []) @?=+        Left (ParseError 0 $ ExpectedInsteadOf "Object" (Array []))+  , testCase "Expect an object, get an object missing a field" $+      runParser (object $ field "foo" number *> field "bar" string) (Object [("foo", Number 1)]) @?=+        Left (ParseError 1 $ ExpectedAsPartOf "field \"bar\"" (Object ([("foo",Number 1.0)])))+  , testCase "Expect an object, get an object with an extra field" $+      runParser (object $ field "foo" number) (Object [("foo", Number 1), ("bar", String "x")]) @?=+        Left (ParseError 1 $ UnexpectedAsPartOf (Object [("bar", String "x")]) (Object [("foo", Number 1), ("bar", String "x")]))+  , testCase "Expect an object, get a field that doesn't match" $+      runParser (object $ field "foo" number) (Object [("foo", String "hi")]) @?=+        Left (ParseError 2 $ ExpectedInsteadOf "Number" (String "hi"))+  , testCase "Expect an object with opt field, field present" $+      runParser (object $ optField "foo" number) (Object [("foo", Number 1)]) @?=+        Right (Just 1)+  , testCase "Expect an object with opt field, field absent" $+      runParser (object $ optField "foo" number) (Object []) @?=+        Right Nothing+  , testCase "Expect an array of number and string, get it" $+      runParser+        (theArray $ (,) <$> element number <*> element string)+        (Array [Number 2, String "hi"])+        @?=+        Right (2, "hi")+  , testCase "Expect an array of number and string, get only number" $+      runParser+        (theArray $ (,) <$> element number <*> element string)+        (Array [Number 2])+        @?=+        Left (ParseError 1 (ExpectedAsPartOf "at least 2 elements" (Array [Number 2])))+  , testCase "Expect an array of number and string, get only string" $+      runParser+        (theArray $ (,) <$> element number <*> element string)+        (Array [String "hi"])+        @?=+        Left (ParseError 2 $ ExpectedInsteadOf "Number" (String "hi"))+  , testCase "Expect an array of number and string, get them and something else" $+      runParser+        (theArray $ (,) <$> element number <*> element string)+        (Array [Number 2, String "hi", Number 42])+        @?=+        Left (ParseError 1 $ UnexpectedAsPartOf (Number 42) (Array [Number 2.0,String "hi",Number 42]))+  ]

@@ -0,0 +1,64 @@+-- Initial yaml-combinators.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                yaml-combinators+version:             1.0+synopsis:            YAML parsing combinators for improved validation and error reporting+-- description:+homepage:            https://github.com/feuerbach/yaml-combinators+license:             MIT+license-file:        LICENSE+author:              Roman Cheplyaka+maintainer:          roma@ro-che.info+copyright:           (c) 2015 Signal Vine, LLC+                     (c) 2017 Roman Cheplyaka+category:            Text+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++library+  exposed-modules:+    Data.Yaml.Combinators+  -- other-modules:+  -- other-extensions:+  build-depends:+    aeson,+    base < 5,+    bytestring,+    generics-sop,+    scientific,+    text,+    transformers,+    unordered-containers,+    vector,+    yaml+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options: -Wall -Wno-orphans++test-suite test+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    tests+  main-is:+    test.hs+  build-depends:+      base+    , aeson+    , tasty+    , tasty-hunit+    , unordered-containers+    , yaml-combinators++test-suite doctests+  type:          exitcode-stdio-1.0+  ghc-options:   -threaded+  hs-source-dirs:+    tests+  main-is:+    doctests.hs+  build-depends: base, doctest