packages feed

json-query 0.1.0.0 → 0.2.0.0

raw patch · 11 files changed

+691/−69 lines, 11 filesdep +contiguousdep +primitive-unlifteddep +profunctors

Dependencies added: contiguous, primitive-unlifted, profunctors

Files

CHANGELOG.md view
@@ -1,5 +1,13 @@ # Revision history for json-query +## 0.2.0.0 -- 2021-09-07++* Add `Monad` implementation for `MemberParser`.+* Add `Alternative` implementation for `Parser` and `MemberParser`.+* Add `Arrow` interface.+* Add textual descriptions to all errors.+* Track all errors in all choice-like typeclasses.+ ## 0.1.0.0 -- 2021-03-22  * Initial release.
json-query.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: json-query-version: 0.1.0.0+version: 0.2.0.0 synopsis: Kitchen sink for querying JSON description:   The library complements json-syntax by making available several@@ -18,18 +18,25 @@  library   exposed-modules:+    Json.Arrow+    Json.Context+    Json.Error+    Json.Errors     Json.Parser     Json.Path   build-depends:+    , array-chunks >=0.1.2 && <0.2     , base >=4.12 && <5-    , json-syntax >=0.2 && <0.3     , bytebuild >=0.3.5 && <0.4-    , text-short >=0.1.3 && <0.2-    , array-chunks >=0.1.2 && <0.2     , bytestring >=0.10 && <0.11+    , contiguous >=0.6.1+    , json-syntax >=0.2 && <0.3     , primitive >=0.7 && <0.8-    , transformers >=0.5.6 && <0.6+    , primitive-unlifted >=0.1.3 && <0.2+    , profunctors >=5.6     , scientific-notation >=0.1.2 && <0.2+    , text-short >=0.1.3 && <0.2+    , transformers >=0.5.6 && <0.6   hs-source-dirs: src   default-language: Haskell2010   ghc-options: -Wall -O2@@ -40,7 +47,9 @@   hs-source-dirs: test   main-is: Main.hs   other-modules:+    Arrowy     DogHouse+    Monadic   ghc-options: -Wall -O2   build-depends:     , array-chunks
+ src/Json/Arrow.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Json.Arrow+  ( Parser+  , type (~>)+  -- * Run Parser+  , run+  -- * Primitive Parsers+  , object+  , array+  , string+  , strings+  , number+  , boolean+  , null+  -- ** Object Members+  , Members+  , member+  , memberOpt+  , foldMembers+  -- ** Array Elements+  , Elements+  , foldl'+  , map+  -- * Primitive Combinators+  , fail+  , failZero+  -- * Trivial Combinators+  , withObject+  , withArray+  , fromNull+  , int+  , word16+  , word64+  -- * Conversion+  , liftMaybe+  ) where++import Prelude hiding (id, (.), fail, map, null)++import Control.Arrow ((>>>))+import Control.Arrow (Arrow(..))+import Control.Arrow (ArrowZero(..),ArrowPlus(..),ArrowChoice(..),ArrowApply(..))+import Control.Category (Category(..))+import Control.Monad.ST (runST)+import Control.Monad.Trans.Except (ExceptT(ExceptT),runExceptT)+import Data.List (find)+import Data.Number.Scientific (Scientific)+import Data.Primitive (SmallArray)+import Data.Primitive.Unlifted.Array (UnliftedArray)+import Data.Profunctor (Profunctor(..))+import Data.Text.Short (ShortText)+import Data.Word (Word16,Word64)+import Json (Value(Object,Array,String,Number), Member(Member))+import Json.Context (Context(..))+import Json.Errors (Errors)+import Json.Error (Error(..))++import qualified Data.Number.Scientific as SCI+import qualified Data.Primitive.Contiguous as Arr+import qualified Json+import qualified Json.Errors as Errors++newtype Parser a b = P+  { unParser :: Context -- ^ reverse list of json keys & indices that have been entered+             -> a -- ^ value to parse+             -> Either Errors (Context, b)+  }+type a ~> b = Parser a b++run :: (a ~> b) -> a -> Either Errors b+run (P p) x = snd <$> p Top x++object :: Value ~> Members+object = P $ \ctx v -> case v of+  Object membs -> Right (ctx, Members membs)+  _ -> Left (Errors.singleton (Error "expected object" ctx))++array :: Value ~> Elements+array = P $ \ctx v -> case v of+  Array membs -> Right (ctx, Elements membs)+  _ -> Left (Errors.singleton (Error "expected array" ctx))++string :: Value ~> ShortText+string = P $ \ctx v -> case v of+  String str -> Right (ctx, str)+  _ -> Left (Errors.singleton (Error "expected string" ctx))++-- | Parse an array of strings. For example:+--+-- > ["hello","world"]+--+-- Failure context includes the index of non-string value if any values in+-- the array are not strings.+strings :: Value ~> UnliftedArray ShortText+strings = P $ \ctx v -> case v of+  Array membs -> runST $ runExceptT $ do+    xs <- Arr.itraverseP+      (\ix e -> case e of+        String s -> pure s+        _ -> ExceptT (pure (Left (Errors.singleton (Error "expected string" (Index ix ctx)))))+      ) membs+    pure (ctx, xs)+  _ -> Left (Errors.singleton (Error "expected array" ctx))++number :: Value ~> Scientific+number = P $ \ctx v -> case v of+  Number n -> Right (ctx, n)+  _ -> Left (Errors.singleton (Error "expected number" ctx))++boolean :: Value ~> Bool+boolean = P $ \ctx v -> case v of+  Json.True -> Right (ctx, True)+  Json.False -> Right (ctx, False)+  _  -> Left (Errors.singleton (Error "expected boolean" ctx))++null :: Value ~> ()+null = P $ \ctx v -> case v of+  Json.Null -> Right (ctx, ())+  _ -> Left (Errors.singleton (Error "expected null" ctx))++newtype Members = Members { unMembers :: SmallArray Member }++member :: ShortText -> Members ~> Value+member k = P $ \ctx xs -> case find keyEq (unMembers xs) of+  Just Member{value} -> Right (Key k ctx, value)+  Nothing -> Left (Errors.singleton (Error ("key not found: " <> k) ctx))+  where+  keyEq Member{key} = k == key++-- | An optional member. Returns Nothing if the value is missing.+memberOpt :: ShortText -> Members ~> Maybe Value+memberOpt k = P $ \ctx xs -> case find keyEq (unMembers xs) of+  Just Member{value} -> Right (Key k ctx, Just value)+  Nothing -> Right (ctx, Nothing)+  where+  keyEq Member{key} = k == key++foldMembers :: a -> (a -> Member ~> a) -> Members ~> a+foldMembers z0 f = P $ \ctx membs ->+  let xs = unMembers membs+      loop !z !i =+        if i < Arr.size xs+        then+          let x@Member{key} = Arr.index xs i+           in case unParser (f z) (Key key ctx) x of+                Right (_, z') -> loop z' (i + 1)+                Left err -> Left err+        else Right (ctx, z)+   in loop z0 0++newtype Elements = Elements { unElements :: SmallArray Value }++foldl' :: a -> (a -> Value ~> a) -> Elements ~> a+foldl' z0 f = P $ \ctx elems ->+  let xs = unElements elems+      loop !z !i =+        if i < Arr.size xs+        then case unParser (f z) (Index i ctx) (Arr.index xs i) of+          Right (_, z') -> loop z' (i + 1)+          Left err -> Left err+        else Right (ctx, z)+   in loop z0 0++map :: (Value ~> a) -> Elements ~> SmallArray a+map (P p) = P $ \ctx (Elements xs) -> runST $ do+  let !len = length xs+  dst <- Arr.new len+  let loop !i = if i < len+        then case p (Index i ctx) (Arr.index xs i) of+          Right (_, y) -> do+            Arr.write dst i y+            loop (i + 1)+          Left err -> pure $ Left err+        else pure $ Right ()+  loop 0 >>= \case+    Right _ -> do+      ys <- Arr.unsafeFreeze dst+      pure $ Right (ctx, ys)+    Left err -> pure $ Left err++instance Functor (Parser a) where+  fmap f (P p) = P $ \ctx x -> case p ctx x of+    Right (ctx', y) -> Right (ctx', f y)+    Left err -> Left err++instance Profunctor Parser where+  dimap g f (P p) = P $ \ctx x -> case p ctx (g x) of+    Right (ctx', y) -> Right (ctx', f y)+    Left err -> Left err++instance Applicative (Parser a) where+  pure x = P $ \ctx _ -> Right (ctx, x)+  (P p) <*> (P q) = P $ \ctx x -> case (p ctx x, q ctx x) of+    (Right (_, f), Right (_, y)) -> Right (ctx, f y)+    (Left err, _) -> Left err+    (_, Left err) -> Left err++instance Category Parser where+  id = P $ \ctx x -> Right (ctx, x)+  (P q) . (P p) = P $ \ctx x -> case p ctx x of+    Right (ctx', y) -> q ctx' y+    Left err -> Left err++instance Arrow Parser where+  arr f = P $ \ctx x -> Right (ctx, f x)+  (P p) *** (P q) = P $ \ctx (x, y) -> case (p ctx x, q ctx y) of+    (Right (_, x'), Right (_, y')) -> Right (ctx, (x', y'))+    (Left err, _) -> Left err+    (_, Left err) -> Left err++instance ArrowZero Parser where+  zeroArrow = failZero++instance ArrowPlus Parser where+  (P p) <+> (P q) = P $ \ctx x -> case p ctx x of+    Right success -> Right success+    Left errLeft -> case q ctx x of+      Right success -> Right success+      Left errRight -> Left $! (errLeft <> errRight)++instance ArrowChoice Parser where+  (P p) +++ (P q) = P $ \ctx -> \case+    Left x -> case p ctx x of+      Right (ctx', y) -> Right (ctx', Left y)+      Left err -> Left err+    Right x -> case q ctx x of+      Right (ctx', y) -> Right (ctx', Right y)+      Left err -> Left err++instance ArrowApply Parser where+  app = P $ \ctx (p, x) -> unParser p ctx x++fail :: ShortText -> a ~> b+fail msg = P $ \ctx _ -> Left (Errors.singleton (Error msg ctx))++failZero :: a ~> b+failZero = P $ \ctx _ -> Left (Errors.singleton (Error "" ctx))++liftMaybe ::+     ShortText -- ^ Message to display on decode error+  -> (a -> Maybe b) -- ^ Decode function+  -> a ~> b+liftMaybe msg f = P $ \ctx x -> case f x of+  Just y -> Right (ctx, y)+  Nothing -> Left (Errors.singleton (Error msg ctx))++withObject :: (Members ~> a) -> Value ~> a+withObject membParser = object >>> membParser++withArray :: (Value ~> a) -> Value ~> SmallArray a+withArray elemParser = array >>> map elemParser++int :: Value ~> Int+int = number >>> liftMaybe "number too big" SCI.toInt++word16 :: Value ~> Word16+word16 = number >>> liftMaybe "number too big" SCI.toWord16++word64 :: Value ~> Word64+word64 = number >>> liftMaybe "number too big" SCI.toWord64++fromNull :: a -> Value ~> a+fromNull z = null >>> pure z
+ src/Json/Context.hs view
@@ -0,0 +1,43 @@+{-# language BangPatterns #-}++module Json.Context+  ( Context(..)+    -- * Encoding+  , builderUtf8+    -- * Conversion+  , toPath+  ) where++import Json.Path (Path)+import Data.Text.Short (ShortText)+import Data.Bytes.Builder (Builder)++import qualified Json.Path as Path++-- | A finger into a json value indicating where a parser is+-- currently operating. When a parser focuses on a key-value+-- pair in a map, it adds 'Key' constructor to the context, and+-- when it focuses on an element of an array, it adds an 'Index'+-- constructor. Like all zipper-like data structures, it is, in+-- a sense, reversed, which makes it cheap to construct while+-- parsing.+data Context+  = Top+  | Key !ShortText !Context+  | Index !Int !Context+  deriving (Eq,Show)++-- | Reverse the context, converting it to a 'Path'.+-- For example, toPath performs this conversion:+--+-- > 12.bar.foo.Top ==> foo.bar.12.Nil+toPath :: Context -> Path+toPath = go Path.Nil where+  go !acc Top = acc+  go !acc (Key k xs) = go (Path.Key k acc) xs+  go !acc (Index i xs) = go (Path.Index i acc) xs++-- | Convert 'Context' to textual representation using UTF-8 as the encoding+-- scheme. This reverses the context to present it in the expected order.+builderUtf8 :: Context -> Builder+builderUtf8 ctx0 = Path.builderUtf8 (toPath ctx0)
+ src/Json/Error.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Json.Error+  ( -- * Types+    Error(..)+    -- * Encoding+  , encode+  , builderUtf8+  ) where++import Data.Bytes.Builder (Builder)+import Data.Text.Short (ShortText)+import Json.Context (Context(..))+import Data.ByteString.Short.Internal (ShortByteString(SBS))++import qualified Data.Bytes.Builder as Builder+import qualified Data.Bytes.Chunks as ByteChunks+import qualified Data.Primitive as PM+import qualified Data.Text.Short.Unsafe as TS+import qualified Json.Context as Context++-- | A single error message.+data Error = Error+  { message :: !ShortText+  , context :: !Context+  } deriving (Eq,Show)++ba2st :: PM.ByteArray -> ShortText+{-# inline ba2st #-}+ba2st (PM.ByteArray x) = TS.fromShortByteStringUnsafe (SBS x)++encode :: Error -> ShortText+encode p = ba2st (ByteChunks.concatU (Builder.run 128 (builderUtf8 p)))++builderUtf8 :: Error -> Builder+builderUtf8 Error{message,context}+  =  Context.builderUtf8 context+  <> Builder.ascii2 ':' ' '+  <> Builder.shortTextUtf8 message++
+ src/Json/Errors.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Json.Errors+  ( -- * Types+    Errors+    -- * Encoding+  , encode+  , builderUtf8+    -- * Create+  , singleton+    -- * Conversion+  , toSmallArray+  ) where++import Data.Bytes.Builder (Builder)+import Data.Primitive (SmallArray)+import Data.Text.Short (ShortText)+import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Control.Monad.ST (runST)+import Json.Error (Error)++import qualified Data.Bytes.Builder as Builder+import qualified Data.Bytes.Chunks as ByteChunks+import qualified Data.Primitive as PM+import qualified Data.Primitive.Contiguous as Arr+import qualified Data.Text.Short.Unsafe as TS+import qualified GHC.Exts as Exts+import qualified Json.Error as Error++-- | A builder for errors that support efficient concatenation.+data Errors+  = ErrorsOne !Error+  | ErrorsPlus !Errors !Errors++instance Semigroup Errors where+  (<>) = ErrorsPlus++instance Show Errors where+  showsPrec d x = showsPrec d (Exts.toList (toSmallArray x))++instance Eq Errors where+  x == y = toSmallArray x == toSmallArray y++singleton :: Error -> Errors+singleton = ErrorsOne++builderUtf8 :: Errors -> Builder+builderUtf8 errs =+  let len = countErrors errs+      errArr = makeErrorArray len errs+   in Error.builderUtf8 (PM.indexSmallArray errArr 0)+      <>+      Arr.foldMap+        (\e -> Builder.ascii2 ',' ' ' <> Error.builderUtf8 e)+        (Arr.slice errArr 1 (len - 1))++-- | Convert errors to array.+toSmallArray :: Errors -> SmallArray Error+toSmallArray e = makeErrorArray (countErrors e) e++makeErrorArrayErrorThunk :: a+{-# noinline makeErrorArrayErrorThunk #-}+makeErrorArrayErrorThunk =+  errorWithoutStackTrace "Json.Arrow.makeErrorArray: implementation mistake"++makeErrorArray :: Int -> Errors -> SmallArray Error+makeErrorArray !len errs0 = runST $ do+  dst <- PM.newSmallArray len makeErrorArrayErrorThunk+  let go !ix errs = case errs of+        ErrorsOne e -> do+          PM.writeSmallArray dst ix e+          pure (ix + 1)+        ErrorsPlus a b -> do+          ix' <- go ix a+          go ix' b+  !finalIx <- go 0 errs0+  if finalIx == len+    then PM.unsafeFreezeSmallArray dst+    else errorWithoutStackTrace "Json.Arrow.makeErrorArray: other impl mistake"++-- postcondition: results is greater than 0.+countErrors :: Errors -> Int+countErrors = go where+  go ErrorsOne{} = 1+  go (ErrorsPlus a b) = go a + go b++ba2st :: PM.ByteArray -> ShortText+{-# inline ba2st #-}+ba2st (PM.ByteArray x) = TS.fromShortByteStringUnsafe (SBS x)++encode :: Errors -> ShortText+encode p = ba2st (ByteChunks.concatU (Builder.run 128 (builderUtf8 p)))
src/Json/Parser.hs view
@@ -7,6 +7,7 @@ {-# language LambdaCase #-} {-# language NamedFieldPuns #-} {-# language RankNTypes #-}+{-# language OverloadedStrings #-}  module Json.Parser   ( Parser(..)@@ -18,6 +19,7 @@   , members     -- * Arrays   , smallArray+  , traverseMembers     -- * Specific Data Constructors   , object   , array@@ -36,25 +38,29 @@  import Prelude hiding (fail) +import Control.Applicative (Alternative(..)) import Control.Monad.ST (runST) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT(ExceptT),runExceptT) import Data.Foldable (foldlM) import Data.List (find)+import Data.Number.Scientific (Scientific) import Data.Primitive (SmallArray) import Data.Text.Short (ShortText) import Data.Word (Word16,Word64) import Json (Value(Object,Array,Number),Member(Member))-import Json.Path (Path(Nil,Key,Index))-import Data.Number.Scientific (Scientific)+-- import Json.Path (Path(Nil,Key,Index))+import Json.Context (Context(Top,Key,Index))+import Json.Errors (Errors)+import Json.Error (Error(..))  import qualified Data.Number.Scientific as SCI import qualified Data.Primitive as PM import qualified Json-import qualified Json.Path as Path+import qualified Json.Errors as Errors  newtype Parser a = Parser-  { runParser :: Path -> Either Path a }+  { runParser :: Context -> Either Errors a }   deriving stock Functor  instance Applicative Parser where@@ -64,13 +70,21 @@     y <- g p     pure (h y) +instance Alternative Parser where+  empty = fail mempty+  f <|> g = Parser $ \p -> case runParser f p of+    Right x -> Right x+    Left aErrs -> case runParser g p of+      Right y -> Right y+      Left bErrs -> Left (aErrs <> bErrs)+ instance Monad Parser where   Parser f >>= g = Parser $ \p -> do     x <- f p     runParser (g x) p  newtype MemberParser a = MemberParser-  { runMemberParser :: Path -> SmallArray Member -> Either Path a }+  { runMemberParser :: Context -> SmallArray Member -> Either Errors a }   deriving stock Functor  instance Applicative MemberParser where@@ -80,23 +94,38 @@     y <- g p mbrs     pure (h y) -run :: Parser a -> Either Path a-run (Parser f) = case f Nil of+instance Alternative MemberParser where+  empty = MemberParser $ \p _ -> Left (Errors.singleton Error{message=mempty,context=p})+  a <|> b = MemberParser $ \p mbrs ->+    case runMemberParser a p mbrs of+      Right x -> Right x+      Left aErrs -> case runMemberParser b p mbrs of+        Right y -> Right y+        Left bErrs -> Left (aErrs <> bErrs)++instance Monad MemberParser where+  parser >>= k = MemberParser $ \p mbrs ->+    case runMemberParser parser p mbrs of+      Left p' -> Left p'+      Right x -> runMemberParser (k x) p mbrs++run :: Parser a -> Either Errors a+run (Parser f) = case f Top of   Right a -> Right a-  Left e -> Left (Path.reverse e)+  Left e -> Left e -fail :: Parser a-fail = Parser (\e -> Left e)+fail :: ShortText -> Parser a+fail !msg = Parser (\e -> Left (Errors.singleton Error{context=e,message=msg}))  object :: Value -> Parser (SmallArray Member) object = \case   Object xs -> pure xs-  _ -> fail+  _ -> fail "expected object"  array :: Value -> Parser (SmallArray Value) array = \case   Array xs -> pure xs-  _ -> fail+  _ -> fail "expected array"  members :: MemberParser a -> SmallArray Member -> Parser a members (MemberParser f) mbrs = Parser (\p -> f p mbrs)@@ -104,33 +133,33 @@ number :: Value -> Parser Scientific number = \case   Number n -> pure n-  _ -> fail+  _ -> fail "expected number"  string :: Value -> Parser ShortText string = \case   Json.String n -> pure n-  _ -> fail+  _ -> fail "expected string"  int :: Scientific -> Parser Int int m = case SCI.toInt m of   Just n -> pure n-  _ -> fail+  _ -> fail "expected number in signed machine integer range"  word16 :: Scientific -> Parser Word16 word16 m = case SCI.toWord16 m of   Just n -> pure n-  _ -> fail+  _ -> fail "expected number in range [0,2^16)"  word64 :: Scientific -> Parser Word64 word64 m = case SCI.toWord64 m of   Just n -> pure n-  _ -> fail+  _ -> fail "expected number in range [0,2^64)"  boolean :: Value -> Parser Bool boolean = \case   Json.True -> pure True   Json.False -> pure False-  _ -> fail+  _ -> fail "expected boolean"  -- members :: Parser Value (Chunks Member) -- members = _@@ -139,7 +168,7 @@ key !name f = MemberParser $ \p mbrs ->   let !p' = Key name p in   case find (\Member{key=k} -> k == name) mbrs of-    Nothing -> Left p'+    Nothing -> Left (Errors.singleton (Error{context=p',message="key not found: " <> name}))     Just Member{value} -> runParser (f value) p'  -- object2 ::@@ -167,12 +196,26 @@       ) 0 xs     lift (PM.unsafeFreezeSmallArray dst) +-- | Traverse the members. The adjusts the context at each member.+traverseMembers :: (Member -> Parser a) -> SmallArray Member -> Parser (SmallArray a)+traverseMembers f !xs = Parser $ \ !p -> runST do+  let !len = length xs+  dst <- PM.newSmallArray len errorThunk+  runExceptT $ do+    !_ <- foldlM+      (\ !ix x@Member{key=k} -> do+        !y <- ExceptT (pure (runParser (f x) (Key k p)))+        lift (PM.writeSmallArray dst ix y)+        pure (ix + 1)+      ) 0 xs+    lift (PM.unsafeFreezeSmallArray dst)+ errorThunk :: a {-# noinline errorThunk #-} errorThunk = errorWithoutStackTrace "Json.Parser: implementation mistake"  -- | Run a parser in a modified context.-contextually :: (Path -> Path) -> Parser a -> Parser a+contextually :: (Context -> Context) -> Parser a -> Parser a {-# inline contextually #-} contextually f (Parser g) = Parser   (\p ->
+ test/Arrowy.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeOperators #-}++module Arrowy+  ( decode+  , badErrors+  ) where++import Prelude hiding (id)++import Control.Arrow ((>>>),(<+>))+import DogHouse(Dog(..),House(..))+import Json.Arrow (type (~>),Members)+import Json.Errors (Errors)+import Json.Error (Error(..))+import Json.Context (Context(Key,Index,Top))+import Data.Primitive (SmallArray)++import qualified GHC.Exts as Exts+import qualified Json+import qualified Json.Arrow as P+import qualified Json.Errors as Errors++decode :: Json.Value -> Either Errors House+decode = P.run (P.object >>> houseMemberParser)++houseMemberParser :: Members ~> House+houseMemberParser = do+  address <- P.member "address" >>> P.string+  dogs <- P.member "dogs" >>> P.withArray (P.withObject dogMemberParser)+  pure House{address,dogs}++dogMemberParser :: Members ~> Dog+dogMemberParser = do+  name <- P.member "name" >>> P.string+  age <- P.member "age" >>> (P.int <+> P.fromNull 0)+  alive <- P.member "alive" >>> P.boolean+  pure Dog{name,age,alive}++badErrors :: Errors+badErrors =+  Errors.singleton (Error "expected number" $ Key "age" $ Index 1 $ Key "dogs" Top)+  <>+  Errors.singleton (Error "expected null" $ Key "age" $ Index 1 $ Key "dogs" Top)
test/DogHouse.hs view
@@ -6,30 +6,23 @@ module DogHouse   ( House(..)   , Dog(..)-  , decode-  , sampleA-  , sampleB-  , expectationA-  , expectationB+  , sampleGood+  , sampleBad+  , expectationGood   ) where -import Control.Monad ((>=>)) import Data.ByteString.Short.Internal (ShortByteString(SBS)) import Data.Bytes (Bytes) import Data.Primitive (ByteArray) import Data.Primitive (SmallArray) import Data.Text.Encoding (encodeUtf8) import Data.Text.Short (ShortText)-import Json.Parser (Parser,MemberParser)-import Json.Path (Path(Key,Index,Nil)) import NeatInterpolation (text)  import qualified Data.ByteString.Short as SBS import qualified Data.Bytes as Bytes import qualified Data.Primitive as PM import qualified GHC.Exts as Exts-import qualified Json-import qualified Json.Parser as P  data House = House   { address :: !ShortText@@ -42,30 +35,11 @@   , alive :: !Bool   } deriving (Eq,Show) -decode :: Json.Value -> Either Path House-decode v = P.run (P.object v >>= P.members houseMemberParser)--houseMemberParser :: MemberParser House-houseMemberParser = do-  address <- P.key "address" P.string-  dogs <- P.key "dogs" $ \v -> do-    arr <- P.array v-    flip P.smallArray arr $ \e -> do-      P.object e >>= P.members dogMemberParser-  pure (House{address,dogs})--dogMemberParser :: MemberParser Dog-dogMemberParser = do-  name <- P.key "name" P.string-  age <- P.key "age" (P.number >=> P.int)-  alive <- P.key "alive" P.boolean-  pure Dog{name,age,alive}- shortByteStringToByteArray :: ShortByteString -> ByteArray  shortByteStringToByteArray (SBS x) = PM.ByteArray x -expectationA :: Either Path House-expectationA = Right House+expectationGood :: House+expectationGood = House   { address = "123 Walsh Street"   , dogs = Exts.fromList     [ Dog@@ -81,11 +55,8 @@     ]   } -expectationB :: Either Path House-expectationB = Left (Key "dogs" $ Index 1 $ Key "age" $ Nil)--sampleA :: Bytes-sampleA = id+sampleGood :: Bytes+sampleGood = id   $ Bytes.fromByteArray   $ shortByteStringToByteArray   $ SBS.toShort@@ -106,8 +77,8 @@   }   |] -sampleB :: Bytes-sampleB = id+sampleBad :: Bytes+sampleBad = id   $ Bytes.fromByteArray   $ shortByteStringToByteArray   $ SBS.toShort
test/Main.hs view
@@ -1,16 +1,28 @@ {-# language LambdaCase #-}+{-# language DuplicateRecordFields #-} {-# language OverloadedStrings #-} +import Control.Arrow ((>>>))+import Data.Bifunctor (first)+import Data.Bytes (Bytes)+import Json.Error (Error(Error)) import Json.Path (Path(Key,Index,Nil)) import Test.Tasty (defaultMain,testGroup,TestTree) import Test.Tasty.HUnit ((@=?)) +import qualified GHC.Exts as Exts import qualified Data.Bytes as Bytes import qualified Json+import qualified Json.Context as Ctx import qualified Json.Path as Path+import qualified Json.Arrow as A+import qualified Json.Errors as Errors import qualified Test.Tasty.HUnit as THU +import qualified Arrowy import qualified DogHouse+import qualified Monadic+import qualified Json.Error  main :: IO () main = defaultMain tests@@ -28,16 +40,49 @@       "$.foo[1].bar"       @=?       Path.encode (Key "foo" $ Index 1 $ Key "bar" $ Nil)-  , THU.testCase "DogHouse-A" $ case Json.decode DogHouse.sampleA of+  , THU.testCase "DogHouse-Monadic-A" $ case Json.decode DogHouse.sampleGood of       Left _ -> fail "failed to parse into syntax tree"        Right val ->-        DogHouse.expectationA+        Right DogHouse.expectationGood         @=?-        DogHouse.decode val-  , THU.testCase "DogHouse-B" $ case Json.decode DogHouse.sampleB of+        Monadic.decode val+  , THU.testCase "DogHouse-Monadic-B" $ case Json.decode DogHouse.sampleBad of       Left _ -> fail "failed to parse into syntax tree"        Right val ->-        DogHouse.expectationB+        Monadic.expectationBad         @=?-        DogHouse.decode val+        Monadic.decode val+  , THU.testCase "DogHouse-Arrowy-A" $ case Json.decode DogHouse.sampleGood of+      Left _ -> fail "failed to parse into syntax tree" +      Right val ->+        Right DogHouse.expectationGood+        @=?+        Arrowy.decode val+  , THU.testCase "DogHouse-Arrowy-B" $ case Json.decode DogHouse.sampleBad of+      Left _ -> fail "failed to parse into syntax tree" +      Right val ->+        Left Arrowy.badErrors+        @=?+        Arrowy.decode val+  , THU.testCase "Arrowy-strings-A" $ case Json.decode sampleArrowyStrings of+      Left _ -> fail "failed to parse into syntax tree" +      Right val ->+        Left+          ( Exts.fromList+            [ Error+              { context = Ctx.Index 2 (Ctx.Key "foo" Ctx.Top)+              , message = "expected string"+              }+            ]+          )+        @=?+        first Errors.toSmallArray (A.run (A.object >>> A.member "foo" >>> A.strings) val)+  , THU.testCase "Arrowy-encode-errors" $+      "$.dogs[1].age: expected number, $.dogs[1].age: expected null"+      @=?+      Errors.encode Arrowy.badErrors   ]++sampleArrowyStrings :: Bytes+sampleArrowyStrings = Bytes.fromAsciiString+  "{\"bla\": true, \"foo\" : [ \"bar\", \"baz\", null, \"hey\"] }"
+ test/Monadic.hs view
@@ -0,0 +1,45 @@+{-# language ApplicativeDo #-}+{-# language NamedFieldPuns #-}+{-# language OverloadedStrings #-}+{-# language QuasiQuotes #-}++module Monadic+  ( decode+  , expectationBad+  ) where++import Control.Monad ((>=>))+import DogHouse(Dog(..),House(..))+import Json.Parser (MemberParser)+import Json.Errors (Errors)+import Json.Error (Error(..))+import Json.Context (Context(Key,Index,Top))++import qualified Json+import qualified Json.Errors as Errors+import qualified Json.Parser as P++decode :: Json.Value -> Either Errors House+decode v = P.run (P.object v >>= P.members houseMemberParser)++houseMemberParser :: MemberParser House+houseMemberParser = do+  address <- P.key "address" P.string+  dogs <- P.key "dogs" $ \v -> do+    arr <- P.array v+    flip P.smallArray arr $ \e -> do+      P.object e >>= P.members dogMemberParser+  pure (House{address,dogs})++dogMemberParser :: MemberParser Dog+dogMemberParser = do+  name <- P.key "name" P.string+  age <- P.key "age" (P.number >=> P.int)+  alive <- P.key "alive" P.boolean+  pure Dog{name,age,alive}++expectationBad :: Either Errors House+expectationBad = Left $ Errors.singleton $ Error+  { context = Key "age" $ Index 1 $ Key "dogs" $ Top+  , message = "expected number"+  }