feat: Type Inference

This commit is contained in:
vegowotenks 2025-08-21 19:58:58 +02:00
parent b078a62ffa
commit cabfbf46ac

54
src/Language/Json/Type.hs Normal file
View file

@ -0,0 +1,54 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
module Language.Json.Type (infer) 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 Language.Json as Json
import qualified Language.Json as Value
import qualified Data.Foldable as Foldable
data Type
= Null
| All -- the inverse of any, supertype of all types
| Number
| String
| Boolean
| Array Type
| Union (Set Type) -- multiple types are allowed here
| Object (Map Text Type)
deriving stock (Show, Ord, Eq)
instance Semigroup Type where
(<>) :: Type -> Type -> Type
(<>) a b = if a == b
then a
else case (a, b) of
(All, _) -> b
(_, 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
(Union typesA, Union typesB) -> Union $ Set.union typesA typesB
(Union typesA, _) -> Union $ Set.insert b typesA
(_, Union typesB) -> Union $ Set.insert a typesB
_ -> Union $ Set.fromList [a, b]
instance Monoid Type where
mempty :: Type
mempty = All
infer :: Json.Value -> Type
infer = \case
Value.Null -> Null
Value.Number _ -> Number
Value.String _ -> String
Value.Boolean _ -> Boolean
Value.Array elements -> Array $ Foldable.foldMap infer elements
Value.Object fields -> Object $ infer <$> fields