toy.hs

{-# LANGUAGE ExistentialQuantification #-}

import Control.Monad

class Toy t
 
data Bike = Bike

instance Toy Bike
 
data Train = Train

instance Toy Train
 
data Address = Address {
  addressNumber :: Int
, addressStreet :: String
, addressPostCode :: String
} deriving (Eq, Show)
 
data Person t = Person {
  personName :: String
, personAge :: Int
, personAddress :: Address
, personToy :: t
} deriving (Eq, Show)
 
type Xml = String
 
class ExEmEl a where
  toXml :: a -> Xml
 
instance ExEmEl Int where
  toXml i = "<int>" ++ show i ++ "</int>"
 
instance ExEmEl Bike where
  toXml = const "<bike/>"
 
instance ExEmEl Train where
  toXml = const "train/>"
 
instance ExEmEl Address where
  toXml a = "<address>" ++
            "<number>" ++ show (addressNumber a) ++ "</number>" ++
            "<street>" ++ addressStreet a ++ "</street>" ++
            "<postcode>" ++ addressPostCode a ++ "</postcode>" ++
            "</address>"
 
instance (Toy t, ExEmEl t) => ExEmEl (Person t) where
  toXml p = "<person>" ++
            "<name>" ++ personName p ++ "</name>" ++
            "<age>" ++ show (personAge p) ++ "</age>" ++ 
            toXml (personAddress p) ++
            toXml (personToy p) ++
            "</person>"
 
data Ball = Ball

instance Toy Ball

instance ExEmEl Ball where
  toXml = const "<ball/>"
 
printXml :: ExEmEl a => a -> IO ()
printXml = putStrLn . toXml

-- You need this boilerplate. 
data ExEmElBox = forall a . ExEmEl a => ExEmElBox a

instance ExEmEl ExEmElBox where
  toXml (ExEmElBox x) = toXml x

main :: IO ()
main = do
  let p = Person "Angelica" 4 (Address 14 "Orchid Drive" "GU24 9SB") Bike
  let q = Person "Angelica" 4 (Address 14 "Orchid Drive" "GU24 9SB") Ball
  let xs = [ExEmElBox p, ExEmElBox q]
  mapM_ printXml xs