Main.hs

{-# LANGUAGE TypeFamilies #-}


data family XList a
data instance XList () = XListUnit Integer
data instance XList Bool = XBits Integer Integer
data instance XList Char = XCons Char (XList Char) | XNil

class XListable a where
  xempty :: XList a
  xcons :: a -> XList a -> XList a
  xheadMay :: XList a -> Maybe a

instance XListable () where
  xempty = XListUnit 0
  
  xcons () (XListUnit n) = XListUnit (n + 1)
  
  xheadMay (XListUnit 0) = Nothing
  xheadMay _ = Just ()

instance XListable Bool where
  xempty = XBits 0 0
  
  xcons b (XBits bits n) = XBits (bits * 2 + if b then 1 else 0) (n + 1) 

  xheadMay (XBits bits n)
    | n <= 0 = Nothing
    | otherwise = Just (bits `mod` 2 /= 0)

instance XListable Char where
  xempty = XNil
  xcons x xs = XCons x xs

  xheadMay (XCons c _) = Just c
  xheadMay XNil = Nothing

test :: (Eq a, XListable a) => a -> Bool
test a = xheadMay (xcons a xempty) == Just a

main = print $ and [test (),
                    test True,
                    test False,
                    test 'x']