From 5655e621de58b94fcc86b13c73686e2542dfbd52 Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Thu, 21 Aug 2025 21:38:05 +0200 Subject: [PATCH] fix: Normalizing unions --- src/Language/Json/Type.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/Language/Json/Type.hs b/src/Language/Json/Type.hs index 9b8d384..d760c30 100644 --- a/src/Language/Json/Type.hs +++ b/src/Language/Json/Type.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternSynonyms #-} module Language.Json.Type (infer, Type(..), isObject) where import Data.Map.Strict (Map) import Data.Text (Text) @@ -21,11 +22,19 @@ data Type | String | Boolean | Array Type - | Union (Set Type) -- multiple types are allowed here + | Union' (Set Type) -- multiple types are allowed here | Object (Map Text Type) deriving stock (Show, Ord, Eq, Generic) deriving PrettySerialize via Generically Type +pattern Union :: Set Type -> Type +pattern Union set <- Union' set where + Union set = let + merged = mergeUnionObjects set + in case Set.toList merged of + [t] -> t + _ -> Union' merged + instance Semigroup Type where (<>) :: Type -> Type -> Type (<>) a b = if a == b @@ -38,10 +47,10 @@ instance Semigroup Type where 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 . mergeUnionObjects $ Set.union typesA typesB - (Union typesA, _) -> Union . mergeUnionObjects $ Set.insert b typesA - (_, Union typesB) -> Union . mergeUnionObjects $ Set.insert a typesB - _ -> Union . mergeUnionObjects $ Set.fromList [a, b] + (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