feat: Type Inference

src/Language/Json/Type.hs

@@ -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
+