feat: checking type to value conformance

hon.cabal

@@ -21,6 +21,7 @@ library
   exposed-modules:
       Language.Json
       Language.Json.Parser
+      Language.Json.Path
       Language.Json.Type
   other-modules:
       Paths_hon

src/Language/Json/Path.hs

@@ -0,0 +1,7 @@
+module Language.Json.Path (Path(..)) where
+import Numeric.Natural (Natural)
+import Data.Text (Text)
+
+data Path
+  = AtIndex Natural
+  | InField Text

src/Language/Json/Type.hs

@@ -3,17 +3,27 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE PatternSynonyms #-}
-module Language.Json.Type (infer, Type(..), isObject) where
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+module Language.Json.Type (infer, Type(..), isObject, conforms, Mismatch(..)) where
 import Data.Map.Strict (Map)
 import Data.Text (Text)
 import Data.Set (Set)
 import qualified Data.Set as Set
-import qualified Data.Map.Merge.Strict as Map
+import qualified Data.Map.Merge.Strict as Map.Merge
 import qualified Language.Json as Json
 import qualified Language.Json as Value
 import qualified Data.Foldable as Foldable
 import GHC.Generics (Generic, Generically(..))
 import Pretty.Serialize (PrettySerialize)
+import Language.Json (Value)
+import Language.Json.Path (Path (AtIndex, InField))
+import qualified Data.Array.IArray as Array
+import qualified Data.List as List
+import Control.Arrow ((>>>))
+import GHC.Records (HasField (getField))
 
 data Type
   = Null
@@ -44,9 +54,9 @@ instance Semigroup Type where
       (_, All) -> a
       (Array elemA, Array elemB) -> Array (elemA <> elemB)
       (Object fieldsA, Object fieldsB) -> let
-        mergeMatched = (Map.zipWithMatched $ const (<>)) -- merge keys present in both maps
-        unionNull    = (Map.mapMissing $ const (<> Null)) -- mark keys missing in either map as nullable
-        in Object $ Map.merge unionNull unionNull mergeMatched fieldsA fieldsB
+        mergeMatched = (Map.Merge.zipWithMatched $ const (<>)) -- merge keys present in both maps
+        unionNull    = (Map.Merge.mapMissing $ const (<> Null)) -- mark keys missing in either map as nullable
+        in Object $ Map.Merge.merge unionNull unionNull mergeMatched fieldsA fieldsB
       (Union typesA, Union typesB) -> Union $ Set.union typesA typesB
       (Union typesA, _) -> Union $ Set.insert b typesA
       (_, Union typesB) -> Union $ Set.insert a typesB
@@ -77,3 +87,38 @@ infer = \case
   Value.Array elements -> Array $ Foldable.foldMap infer elements
   Value.Object fields -> Object $ infer <$> fields
 
+
+data Mismatch = Mismatch
+  { expected :: Type
+  , inferred :: Type
+  , value    :: Value
+  , path     :: [Path]
+  }
+
+instance HasField "actual" Mismatch Type where
+  getField :: Mismatch -> Type
+  getField = (.inferred)
+
+conforms :: Type -> Json.Value -> [Mismatch]
+conforms = conforms' []
+
+
+conforms' :: [Path] -> Type -> Value -> [Mismatch]
+conforms' path layout value = case (value, layout) of
+  (_, All) -> mempty -- matches all the types
+  -- exact matches
+  (Value.Null, Null) -> mempty
+  (Value.Boolean _, Boolean) -> mempty
+  (Value.Number _, Number) -> mempty
+  (Value.String _, String) -> mempty
+  (Value.Array elements, Array elementType) -> Array.assocs 
+    >>> List.concatMap (\ (i, e) -> conforms' (AtIndex i:path) elementType e)
+    $ elements
+  (Value.Object fields, Object fieldTypes) -> let
+      bothPresent  = Map.Merge.zipWithMatched $ \ key -> conforms' (InField key:path) -- fields must match the recorded type
+      typeMissing  = Map.Merge.mapMissing $ \ key -> conforms' (InField key:path) Null -- non-present types are equivalent to Null
+      fieldMissing = Map.Merge.mapMissing $ \ key fieldType -> conforms' (InField key:path) fieldType Value.Null
+      mismatches   = Map.Merge.merge fieldMissing typeMissing bothPresent fieldTypes fields
+    in Foldable.concatMap id mismatches
+  _ -> pure $ Mismatch {expected=layout, inferred=infer value, value=value, path=path}
+