Union types (with explicit upcast) in Haskell

Main.hs

-- Example usage
module Main where

import Union


unionValue1 :: Union (String, (Double, ((Int, Int), ())))
unionValue1 = mkUnion "Foo"

unionValue2 :: Union (String, (Double, ((Int, Int), ())))
unionValue2 = upcast (mkUnion 1.5)

unionValue3 :: Union (String, (Double, ((Int, Int), ())))
unionValue3 = upcast (upcast (mkUnion (4,5)))


showFirst :: Union (String, (Double, ((Int, Int), ()))) -> String
showFirst union = case typeCase union of
    Left string -> string
    Right union' -> case typeCase union' of
      Left double -> show double
      Right union'' -> case finalCase union'' of
        (x,y) -> show x

-- |
-- >>> main
-- 4
main :: IO ()
main = do print (showFirst unionValue1)
          print (showFirst unionValue2)
          print (showFirst unionValue3)

Union.hs

{-# LANGUAGE ExistentialQuantification #-}
module Union (Union, mkUnion, upcast, typeCase, finalCase) where

import Data.Typeable


data Union u = forall a. Typeable a => PrivateUnion a

mkUnion :: Typeable a => a -> Union (a, u)
mkUnion x = PrivateUnion x

upcast :: Typeable a => Union u -> Union (a, u)
upcast (PrivateUnion x) = PrivateUnion x

typeCase :: Typeable a => Union (a, u) -> Either a (Union u)
typeCase (PrivateUnion x) = case cast x of
    Just y  -> Left y
    Nothing -> Right (PrivateUnion x)

finalCase :: Typeable a => Union (a, ()) -> a
finalCase union = case typeCase union of
    Left x -> x
    Right y -> y `seq` error msg
      where
        msg = "never happens, as a Union () cannot be constructed."