LightAndLight · August 19, 2020 05:15 · Aug 19, 2020
diff --git a/Json.hs b/Json.hs
@@ -0,0 +1,136 @@
+{-# 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'
No results found