Commit f888eb87 authored by sewardj's avatar sewardj
Browse files

[project @ 2001-06-20 15:57:19 by sewardj]

Hey!  This game is easy.
parent 5cef8976
include ($confdir ++ "/../vanilla-test.T")
-- Args to vt are: extra compile flags
-- extra run flags
-- expected process return value, if not zero
test "tcrun001" { vt("", "", "") }
test "tcrun002" { vt("", "", "") }
test "tcrun003" { vt("-fglasgow-exts", "", "") }
test "tcrun004" { vt("-fglasgow-exts", "", "") }
test "tcrun005" { vt("", "", "") }
test "tcrun006" { vt("", "", "") }
test "tcrun007" { vt("", "", "") }
test "tcrun008" { vt("", "", "") }
test "tcrun009" { vt("", "", "") }
test "tcrun010" { vt("", "", "") }
test "tcrun011" { vt("", "", "") }
test "tcrun012" { vt("", "", "") }
test "tcrun013" { vt("", "", "") }
-- !! Test for (->) instances
module Main where
class Flob k where
twice :: k a a -> k a a
instance Flob (->) where
twice f = f . f
inc :: Int -> Int
inc x = x+1
main = print (twice inc 2)
-- !!! space leak from overloading !!!
module Main where
-- This program develops a space leak if sfoldl isn't compiled with some
-- care. See comment about polymorphic recursion in TcMonoBinds.lhs
import System(getArgs)
import PrelIOBase
sfoldl :: (a -> Int -> a) -> a -> [Int] -> a
sfoldl f z [] = z
sfoldl f z (x:xs) = _scc_ "sfoldl1" (sfoldl f fzx (fzx `seq` xs))
where fzx = _scc_ "fzx" (f z x)
main = IO (\s -> case print (sfoldl (+) (0::Int) [1..200000]) of { IO a -> a s })
-- !!! One method class from Sergey Mechveliani
-- showed up problematic newtype dict rep.
module Main where
import Ratio
class MBConvertible a b where cm :: a -> b -> Maybe b
c :: MBConvertible a b => a -> b -> b
c a b = case cm a b
of
Just b' -> b'
_ -> error "c a b failed"
instance MBConvertible Int Int where cm a _ = Just a
instance (MBConvertible a b,Integral b) => MBConvertible a (Ratio b)
where
cm a f = case cm a (numerator f) of Just a' -> Just (a'%1)
_ -> Nothing
main = let f = 1%1 :: Ratio Int
n2 = 2::Int
g = (c n2 f) + f
in
putStr (shows g "\n")
-- !!! Tests existential data types
-- Originally from Kevin Glynn
module Main(main) where
data Coordinate3D = Coord3D {cx, cy, cz::Double}
deriving (Eq, Show)
-- We Represent a line by two coordinates which it passes through.
data Line = MkLine Coordinate3D Coordinate3D
class PictureObject pot where
-- Returns ordered (rel to 0 0 0) of points where the object
-- intersects the given line.
intersectLineObject :: pot -> Line -> [Coordinate3D]
getPictureName :: pot -> String
data Sphere =
Sphere Coordinate3D -- Centre
Double -- Radius
Double -- ambient coeff
Double -- diffuse coeff
Double -- specular coeff
Double -- phong specular exponent
intersectLineSphere :: Sphere -> Line -> [Coordinate3D]
intersectLineSphere sp line = []
instance PictureObject Sphere where
intersectLineObject = intersectLineSphere
getPictureName _ = "Sphere"
data Cube =
Cube Coordinate3D -- Origin corner
Coordinate3D -- Opposite corner
Double -- ambient coeff
Double -- diffuse coeff
Double -- specular coeff
Double -- phong specular exponent
deriving (Eq, Show)
intersectLineCube :: Cube -> Line -> [Coordinate3D]
intersectLineCube cube line = []
instance PictureObject Cube where
intersectLineObject = intersectLineCube
getPictureName _ = "Cube"
data GenPic = forall pot. (PictureObject pot) => MkGenPic pot
sphere :: Sphere
sphere = Sphere (Coord3D 1 1 1) 1 1 1 1 1
cube :: Cube
cube = Cube (Coord3D 1 1 1) (Coord3D 2 2 2) 1 1 1 1
obj_list:: [GenPic]
obj_list = [MkGenPic sphere, MkGenPic cube]
putName :: PictureObject pot => pot -> IO ()
putName x = putStr $ getPictureName x
main :: IO ()
main = do { sequence_ $ map put_it obj_list }
where
put_it (MkGenPic s) = putStrLn (getPictureName s)
-- !!! Dfun naming bug
module Main where
data TT = TT
data TTT = TTT
class CC a where
op_cc :: a -> a
class CCT a where
op_cct :: a -> a
-- These two instances should get different dfun names!
-- In GHC 4.04 they both got $fCCTTT
instance CC TTT where
op_cc = id
instance CCT TT where
op_cct = id
main = case op_cc TTT of
TTT -> print "ok"
-- !!! Selectors for data and newtypes with contexts
-- This program, reported in Aug'00 by Jose Emilio Labra Gayo
-- gave rise to a Lint error because the selector 'newout' below
-- was given the type
-- Eq f => NewT f -> f
-- but lacked a dictionary argument in its body.
module Main where
newtype (Eq f) => NewT f = NewIn { newout :: f }
data (Eq f) => DataT f = DataIn { dataout :: f }
main = print (newout (NewIn "ok new") ++ dataout (DataIn " ok data"))
{-# 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
{-# OPTIONS -fglasgow-exts #-}
-- !!! Check that record selectors for polymorphic fields work right
module Main where
import IO
class Foo a where
bar :: a -> [a]
instance Foo Int where
bar x = replicate x x
instance Foo Bool where
bar x = [x, not x]
data Record = R {
blub :: Foo a => a -> [a]
}
main = do { let r = R {blub = bar}
; print (blub r (3::Int))
; print (blub r True)
}
{-# OPTIONS -fglasgow-exts #-}
-- !!! Functional dependencies
module Main where
class Foo a b | a -> b where
foo :: a -> b
instance Foo [a] (Maybe a) where
foo [] = Nothing
foo (x:_) = Just x
instance Foo (Maybe a) [a] where
foo Nothing = []
foo (Just x) = [x]
test3:: [a] -> [b]
test3 = foo . foo
-- First foo must use the first instance,
-- second must use the second. So we should
-- get in effect: test3 (x:xs) = [x]
main:: IO ()
main = print (test3 "foo" :: [Int])
{-# OPTIONS -fglasgow-exts #-}
-- !!! Functional dependencies
-- This one gave "zonkIdOcc: FunDep_a11w" in earlier days
module Main (main) where
data ERR a b = EOK a | ERR b deriving (Show)
data Error = No | Notatall deriving (Show, Eq)
class MonadErr m e | m -> e where
aerturn :: e -> m a
areturn :: a -> m a
acatch :: a -> (a -> m b) -> (e -> m b) -> m b
(>>>=) :: m a -> (a -> m b) -> m b
(>>>) :: m a -> m b -> m b
data BP a = BP (Int -> (ERR a Error, Int))
instance MonadErr BP Error where
aerturn k = BP $ \s -> (ERR k, s)
areturn k = BP $ \s -> (EOK k, s)
acatch k try handler = BP $ \s -> let BP try' = try k
(r,s1) = try' s
(BP c2, s2) = case r of
EOK r -> (areturn r, s1)
ERR r -> (handler r, s)
in c2 s2
a >>> b = a >>>= \_ -> b
(BP c1) >>>= fc2 = BP $ \s0 -> let (r,s1) = c1 s0
BP c2 = case r of
EOK r -> fc2 r
ERR r -> BP (\s -> (ERR r, s))
in c2 s1
run_BP :: Int -> BP a -> (ERR a Error, Int)
run_BP st (BP bp) = bp st
foo :: (ERR Int Error, Int)
foo = run_BP 111 (aerturn No)
main = print (show foo)
Supports Markdown
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