Commit dc4239eb authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-05 16:18:03 by simonpj]

Add test for generics
parent 2d1987b1
{-# OPTIONS -fglasgow-exts -fgenerics #-}
-- !!! Test generics
module Main where
import PrelBase -- In a real program it would be 'import Generics'
-- but Generics is in package lang, so importing
-- PrelBase reduces dependencies
class Bin a where
toBin :: a -> [Int]
fromBin :: [Int] -> (a, [Int])
toBin {| Unit |} Unit = []
toBin {| a :+: b |} (Inl x) = 0 : toBin x
toBin {| a :+: b |} (Inr y) = 1 : toBin y
toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y
fromBin {| Unit |} bs = (Unit, bs)
fromBin {| a :+: b |} (0:bs) = (Inl x, bs') where (x,bs') = fromBin bs
fromBin {| a :+: b |} (1:bs) = (Inr y, bs') where (y,bs') = fromBin bs
fromBin {| a :*: b |} bs = (x :*: y, bs'') where (x,bs' ) = fromBin bs
(y,bs'') = fromBin bs'
class Tag a where
nCons :: a -> Int
nCons {| Unit |} _ = 1
nCons {| a :*: b |} _ = 1
nCons {| a :+: b |} _ = nCons (bot::a) + nCons (bot::b)
tag :: a -> Int
tag {| Unit |} _ = 1
tag {| a :*: b |} _ = 1
tag {| a :+: b |} (Inl x) = tag x
tag {| a :+: b |} (Inr y) = nCons (bot::a) + tag y
bot = bot
instance (Bin a, Bin b) => Bin (a,b)
instance Bin a => Bin [a]
instance Bin a => Bin (T a)
instance Bin Int where
toBin x = [x]
fromBin (x:xs) = (x,xs)
data T a = MkT a (T a) (T a) | Nil deriving Show
instance Tag Colour
data Colour = Red | Blue | Green | Purple | White
t :: T Int
t = MkT 3 (MkT 6 Nil Nil) Nil
main = print (toBin t) >>
print ((fromBin (toBin t))::(T Int,[Int])) >>
print (tag Blue) >>
print (tag White) >>
print (nCons Red)
[0,3,0,6,1,1,1]
(MkT 3 (MkT 6 Nil Nil) Nil,[])
2
5
5
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment