vegowotenks/hon
1
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

fix: Normalizing unions

Browse source
This commit is contained in:
vegowotenks 2025-08-21 21:38:05 +02:00
parent 4f9cec2d51
commit 5655e621de
1 changed files with 14 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

19
src/Language/Json/Type.hs
View file

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