ghc/tests/typecheck/should_run/tcrun007.hs

   1 {-# OPTIONS -fglasgow-exts -fgenerics #-}
   2
   3 -- !!! Test generics
   4 module Main where
   5
   6 import PrelBase         -- In a real program it would be 'import Generics'
   7                         -- but Generics is in package lang, so importing
   8                         -- PrelBase reduces dependencies
   9
  10 class Bin a where
  11   toBin   :: a -> [Int]
  12   fromBin :: [Int] -> (a, [Int])
  13
  14   toBin {| Unit |}    Unit      = []
  15   toBin {| a :+: b |} (Inl x)   = 0 : toBin x
  16   toBin {| a :+: b |} (Inr y)   = 1 : toBin y
  17   toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y
  18
  19
  20   fromBin {| Unit |}    bs      = (Unit, bs)
  21   fromBin {| a :+: b |} (0:bs)  = (Inl x, bs') where (x,bs') = fromBin bs
  22   fromBin {| a :+: b |} (1:bs)  = (Inr y, bs') where (y,bs') = fromBin bs
  23   fromBin {| a :*: b |} bs      = (x :*: y, bs'') where (x,bs' ) = fromBin bs
  24                                                         (y,bs'') = fromBin bs'
  25
  26
  27 class Tag a where
  28   nCons :: a -> Int
  29   nCons {| Unit |}    _ = 1
  30   nCons {| a :*: b |} _ = 1
  31   nCons {| a :+: b |} _ = nCons (bot::a) + nCons (bot::b)
  32
  33   tag :: a -> Int
  34   tag {| Unit |}    _       = 1
  35   tag {| a :*: b |} _       = 1
  36   tag {| a :+: b |} (Inl x) = tag x
  37   tag {| a :+: b |} (Inr y) = nCons (bot::a) + tag y
  38
  39 bot = bot
  40
  41 instance (Bin a, Bin b) => Bin (a,b)
  42 instance Bin a => Bin [a]
  43 instance Bin a => Bin (T a)
  44
  45 instance Bin Int where
  46   toBin x = [x]
  47   fromBin (x:xs) = (x,xs)
  48
  49 data T a = MkT a (T a) (T a) | Nil deriving Show
  50
  51 instance Tag Colour
  52 data Colour = Red | Blue | Green | Purple | White
  53
  54 t :: T Int
  55 t = MkT 3 (MkT 6 Nil Nil) Nil
  56
  57 main = print (toBin t) >>
  58        print ((fromBin (toBin t))::(T Int,[Int])) >>
  59        print (tag Blue) >>
  60        print (tag White) >>
  61        print (nCons Red)
  62