diff --git a/hon.cabal b/hon.cabal index 777edac..d226fde 100644 --- a/hon.cabal +++ b/hon.cabal @@ -21,6 +21,7 @@ library exposed-modules: Language.Json Language.Json.Parser + Language.Json.Path Language.Json.Type other-modules: Paths_hon diff --git a/src/Language/Json/Path.hs b/src/Language/Json/Path.hs new file mode 100644 index 0000000..5817379 --- /dev/null +++ b/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 diff --git a/src/Language/Json/Type.hs b/src/Language/Json/Type.hs index d760c30..eb142ec 100644 --- a/src/Language/Json/Type.hs +++ b/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} +