json-query-0.2.0.0: test/Monadic.hs

{-# 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"
  }