How to shrink an union type in Haskell?

Question

I'm using OpenUnion a type from world-peace library and I'd like to write a function which will transform an union into a narrower one if possible:

unionShrink :: Contains bs as => OpenUnion as -> Maybe (OpenUnion bs)

Contains bs as typeclass means bs ⊂ as. Union represents one value of the type in the list in the type parameter, hence Maybe, which means that the first union may contain a value which is of the type which is not in the second (narrower) union.

How to do that?

Answer 1

I feel like there should be an easier way and I'm not very proud of the names, but here's one way to do it:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}

import Data.WorldPeace
import Data.Functor.Identity
import Data.Proxy
import Data.Type.Equality
import Data.Kind

class MaybeIsMember a as where
  maybeIsMember :: a -> Maybe (OpenUnion as)

class MaybeIsMember' eq a b bs where
  maybeIsMember' :: Proxy eq -> a -> Maybe (OpenUnion (b : bs))

instance MaybeIsMember' 'False a b '[] where
  maybeIsMember' _ _ = Nothing
instance MaybeIsMember' (a == b') a b' bs => MaybeIsMember' 'False a b (b' : bs) where
  maybeIsMember' _ x = That <$> maybeIsMember' (Proxy @(a == b')) x
instance MaybeIsMember' 'True a a bs where
  maybeIsMember' _ x = Just (This (Identity x))

instance forall a b bs. MaybeIsMember' (a == b) a b bs => MaybeIsMember a (b : bs) where
  maybeIsMember = maybeIsMember' (Proxy @(a == b))
instance MaybeIsMember a '[] where
  maybeIsMember _ = Nothing

type MaybeContains :: [Type] -> [Type] -> Constraint
type family MaybeContains as bs where
  MaybeContains '[] _ = ()
  MaybeContains (x : xs) ys = (MaybeIsMember x ys, MaybeContains xs ys)

-- Data.WorldPeace.openUnion is a bit too restrictive, so here's a better version
openUnion' :: (forall a as. (bs ~ (a : as)) => Either a (OpenUnion as) -> c) -> OpenUnion bs -> c
openUnion' f (This (Identity x)) = f (Left x)
openUnion' f (That x) = f (Right x)

unionShrink :: MaybeContains as bs => OpenUnion as -> Maybe (OpenUnion bs)
unionShrink = openUnion' (either maybeIsMember unionShrink)

It works fine for simple monomorphic examples:

ghci> let int = 3 :: Int
ghci> let o = openUnionLift int :: OpenUnion '[String, Int]
ghci> unionShrink o :: Maybe (OpenUnion '[Int])
Just (Identity 3)

But I doubt it will work very well when polymorphism is involved.