typed json access with paths

Json.hs

{-# language GADTs, KindSignatures, StandaloneDeriving #-}
module Json
  ( JsonType(..), SomeJsonType(..)
  , Segment(..)
  , prettySegment
  , Path(..)
  , append
  , prettyPath
  , JsonError(..)
  , typeOf
  , as
  , get
  )
where

import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import Data.Scientific (Scientific)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Vector as Vector

data JsonType :: * -> * where
  Object :: JsonType Aeson.Object
  Array :: JsonType Aeson.Array
  Number :: JsonType Scientific
  String :: JsonType Text
  Bool :: JsonType Bool
  Null :: JsonType ()
deriving instance Show (JsonType ty)

data Segment :: * -> * -> * where
  Key :: Text -> Segment Aeson.Value Aeson.Value
  Ix :: Int -> Segment Aeson.Value Aeson.Value
  Type :: JsonType ty -> Segment Aeson.Value ty
deriving instance Show (Segment a b)

data Path :: * -> * -> * where
  Nil :: Path a a
  (:>) :: Segment a b -> Path b c -> Path a c
deriving instance Show (Path a b)
infixr 5 :>

append :: Path a b -> Path b c -> Path a c
append a b =
  case a of
    Nil -> b
    aa :> aas -> aa :> append aas b

prettySegment :: Segment a b -> String
prettySegment seg =
  case seg of
    Key k -> "." <> Text.unpack k
    Ix ix -> "[" <> show ix <> "]"
    Type ty ->
      ".(" <>
      (case ty of
         Object -> "object"
         Array -> "array"
         Number -> "number"
         String -> "string"
         Bool -> "bool"
         Null -> "null"
      ) <>
      ")"

prettyPath :: Path a b -> String
prettyPath p =
  case p of
    Nil -> "."
    a :> rest ->
      prettySegment a <>
      case rest of
        Nil -> mempty
        _ :> _ -> prettyPath rest

data SomeJsonType where
  Some :: JsonType ty -> SomeJsonType

data JsonError where
  Mismatch :: { path :: String, expected :: JsonType ty, actual :: JsonType ty' } -> JsonError
  MissingKey :: { path :: String, key :: Text } -> JsonError
  MissingIndex :: { path :: String, index :: Int } -> JsonError

deriving instance Show JsonError

typeOf :: Aeson.Value -> SomeJsonType
typeOf val =
  case val of
    Aeson.Object{} -> Some Object
    Aeson.Array{} -> Some Array
    Aeson.Number{} -> Some Number
    Aeson.String{} -> Some String
    Aeson.Bool{} -> Some Bool
    Aeson.Null{} -> Some Null

as_ :: Path a b -> Aeson.Value -> JsonType ty -> Either JsonError ty
as_ p val ty =
  case ty of
    Object | Aeson.Object a <- val -> pure a
    Array | Aeson.Array a <- val -> pure a
    Number | Aeson.Number a <- val -> pure a
    String | Aeson.String a <- val -> pure a
    Bool | Aeson.Bool a <- val -> pure a
    Null | Aeson.Null <- val -> pure ()
    _ -> mkErr ty
  where
    mkErr ex =
      case typeOf val of
        Some ac -> Left $ Mismatch (prettyPath p) ex ac

as :: Aeson.Value -> JsonType ty -> Either JsonError ty
as = as_ Nil

get :: Path a b -> a -> Either JsonError b
get = go Nil
  where
    go :: Path a b -> Path b c -> b -> Either JsonError c
    go current p val =
      case p of
        Nil -> pure val
        seg :> rest ->
          case seg of
            Key k -> do
              val' <- as_ current val Object
              case HashMap.lookup k val' of
                Nothing -> Left $ MissingKey { path = prettyPath current, key = k }
                Just val'' -> go (append current $ Key k :> Nil) rest val''
            Ix ix -> do
              val' <- as_ current val Array
              case val' Vector.!? ix of
                Nothing -> Left $ MissingIndex { path = prettyPath current, index = ix }
                Just val'' -> go (append current $ Ix ix :> Nil) rest val''
            Type ty -> do
              val' <- as_ current val ty
              go (append current $ Type ty :> Nil) rest val'