Commit 4f3a880c authored by sewardj's avatar sewardj

[project @ 2001-06-22 11:53:44 by sewardj]

Add simplifier tests.
parent f28cb04d
......@@ -15,4 +15,12 @@ rename/should_compile
rn037 issues
stranal/should_compile
There are some failures in here due to unexpected stdouts
(the compiler isn't asked to generate any?)
specialise/
Contains complete progs. Not done yet.
simpleCore/should_compile
simpl006 has extra bits
module Simpl006Help( forever ) where
forever c = sequence_ (repeat c)
include ($confdir ++ "/../vanilla-test.T")
-- Args to vtc are: extra compile flags
-- Use this itsy helper fn to pass in an extra flag
--def myvtc($extra_comp_args)
--{
-- vtc(" -fno-warn-incomplete-patterns " ++ $extra_comp_args)
--}
--Simpl006Help.hs
--Simpl006Help_HC_OPTS = -O
test "simpl001" { vtc("") }
test "simpl002" { vtc("") }
test "simpl003" { vtc("") }
test "simpl004" { vtc("-package lang") }
test "simpl005" { vtc("") }
test "simpl006" { vtc("-package concurrent") }
test "simpl007" { vtc("") }
-- !!! Desugaring sections with function-type arguments
-- Although this is really a desugaring test, the problem is
-- only tickled by the simplifier
-- type Foo a b = a -> (b -> a) -> b
module ShouldCompile where
(++++) :: (a -> (b -> a) -> b) -> (a -> (b -> a) -> b) -> a -> (b -> a) -> b
x ++++ y = y
g a xs = map (++++ a) xs
h b xs = map (b ++++) xs
-- !!! class/instance mumble that failed Lint at one time
--
module ShouldCompile where
class Foo a where
op :: Int -> a -> Bool
data Wibble a b c = MkWibble a b c
instance (Foo a, Foo b, Foo c) => Foo (Wibble a b c) where
op x y = error "xxx"
-- !! INLINE on recursive functions.
{-
Date: Thu, 8 Dec 94 11:38:24 GMT
From: Julian Seward (DRL PhD) <sewardj@computer-science.manchester.ac.uk>
Message-Id: <9412081138.AA16652@rdf009.cs.man.ac.uk>
To: partain@dcs.gla.ac.uk
-}
module ShouldCompile where
type IMonad a
= IMonadState -> IMonadReturn a
data IMonadReturn a
= IMonadOk IMonadState a
| IMonadFail IMonadState String
type IMonadState
= Int
returnI r = \s0 -> IMonadOk s0 r
failI msg = \s0 -> IMonadFail s0 msg
thenI m k
= \s0 -> case m s0 of
IMonadFail s1 msg -> IMonadFail s1 msg
IMonadOk s1 r1 -> k r1 s1
tickI n = \s0 -> IMonadOk (s0+n) ()
mapI f [] = returnI []
mapI f (x:xs) = f x `thenI` ( \ fx ->
mapI f xs `thenI` ( \ fxs ->
returnI (fx:fxs)
))
{-# INLINE returnI #-}
{-# INLINE failI #-}
{-# INLINE thenI #-}
{-# INLINE tickI #-}
{-# INLINE mapI #-}
{-# OPTIONS -fglasgow-exts #-}
module ShouldCompile where
import Ix
import GlaExts
f ixs@(_, ix_end) frozen# =
let
n# =
case (
if null (range ixs)
then 0
else 1
) of { I# x -> x }
in
(# frozen#, False #)
-- !!! CPR on newtype with polymorphic argument
{-# OPTIONS -O #-}
module ShouldCompile where
data StateM m s a = STM (s -> m (a,s))
instance Functor m => Functor (StateM m s) where
fmap f (STM xs) = STM (\s -> fmap (\ (x,s') -> (f x, s'))
(xs s)
)
{- With GHC 4.04 (first release) this program gave:
panic! (the `impossible' happened):
mk_cpr_let: not a product
forall a{-ruq-} b{-rur-}.
(a{-ruq-} -> b{-rur-})
-> MonadLibrary.StateM{-r2o,x-} m{-a30Y-} s{-a30Z-} a{-ruq-}
-> MonadLibrary.StateM{-r2o,x-} m{-a30Y-} s{-a30Z-} b{-rur-}
The reason: 'Functor' is a newtype, whose element is a for-all type.
newtype Functor f = Functor (forall a,b. (a->b) -> f a -> f b)
-}
-- !!! This one sent 4.06 into an infinite loop
-- But it worked ok if Simpl006Help.forever is
-- defined in this module. I have no idea why!
{-# OPTIONS -O #-}
module ShouldCompile where
import Concurrent
import Simpl006Help
after :: Int -> IO a -> IO a
after d c = c
every :: Int -> IO a -> IO ()
every d c = forever (after d c)
{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}
-- module Formula where
module Main where
import Prelude hiding (logBase)
import Maybe
-------------------------------------------------------------------------------
-- Formula
-- The data type for formulas (algegraic expressions).
--
-- It should be an extensible type, so that users of
-- the library can add new kinds of formulas.
-- For example, in this prototype I explore:
-- integer constants (FInt)
-- unknown variables (FVar)
-- sums (FSum)
-- products (FPro)
-- powers (FPow)
-- logarithms (FLog)
-- The user of the library may want to extend it with
-- trigonometric formulas or derivative formulas, for
-- example.
--
-- The idea is to let each kind of formula be a new data
-- type. Similar operations with them are implemented
-- using overloading. So there is a class (FORMULA) to collect
-- them and each kind of formula should be an instance of it.
class (Eq f, Show f) => FORMULA f where
ty :: f -> FType
intVal :: f -> Integer
varName :: f -> String
argList :: f -> [Formula]
same :: (FORMULA f1) => f -> f1 -> Bool
intVal = error ""
varName = error ""
argList = error ""
same _ _ = False
-- By now extensibility is accomplished by existentialy
-- quantified type variables.
data Formula = forall f . ( FORMULA f
, AddT f
) =>
Formula f
instance Show Formula where
show (Formula f) = show f
instance Eq Formula where
(Formula x) == (Formula y) = same x y
instance FORMULA Formula where
ty (Formula f) = ty f
intVal (Formula f) = intVal f
varName (Formula f) = varName f
argList (Formula f) = argList f
same (Formula f) = same f
-------------------------------------------------------------------------------
-- How to uniquely identify the type of formula?
-- Each type of formula is associated to a key (FType)
-- that identifies it.
--
-- Here I use an enumated data type. When extending
-- the library, the user will have to modify this
-- data type adding a new constant constructor.
data FType = INT
| VAR
| SUM
| PRO
| POW
| LOG
deriving (Eq,Ord,Enum,Show)
-------------------------------------------------------------------------------
-- Integer formula
data FInt = FInt Integer
deriving (Eq,Show)
mkInt = Formula . FInt
instance FORMULA FInt where
ty _ = INT
intVal (FInt x) = x
same (FInt x) y = isInt y && x == intVal y
-- Variable formula
data FVar = FVar String
deriving (Eq,Show)
mkVar = Formula . FVar
instance FORMULA FVar where
ty _ = VAR
varName (FVar x) = x
same (FVar x) y = isVar y && x == varName y
-- Sum formula
data FSum = FSum [Formula]
deriving (Eq,Show)
mkSum = Formula . FSum
instance FORMULA FSum where
ty _ = SUM
argList (FSum xs) = xs
same (FSum xs) y = isSum y && xs == argList y
-- Product formula
data FPro = FPro [Formula]
deriving (Eq,Show)
mkPro = Formula . FPro
instance FORMULA FPro where
ty _ = PRO
argList (FPro xs) = xs
same (FPro xs) y = isPro y && xs == argList y
-- Exponentiation formula
data FPow = FPow Formula Formula
deriving (Eq,Show)
mkPow x y = Formula (FPow x y)
instance FORMULA FPow where
ty _ = POW
argList (FPow b e) = [b,e]
same (FPow b e) y = isPow y && [b,e] == argList y
-- Logarithm formula
data FLog = FLog Formula Formula
deriving (Eq,Show)
mkLog x b = Formula (FLog x b)
instance FORMULA FLog where
ty _ = LOG
argList (FLog x b) = [x,b]
same (FLog x b) y = isLog y && [x,b] == argList y
-------------------------------------------------------------------------------
-- Some predicates
isInt x = ty x == INT
isVar x = ty x == VAR
isSum x = ty x == SUM
isPro x = ty x == PRO
isPow x = ty x == POW
isZero x = isInt x && intVal x == 0
-------------------------------------------------------------------------------
-- Adding two formulas
-- This is a really very simple algorithm for adding
-- two formulas.
add :: Formula -> Formula -> Formula
add x y
| isJust u = fromJust u
| isJust v = fromJust v
| otherwise = mkSum [x,y]
where
u = addT x y
v = addT y x
class AddT a where
addT :: a -> Formula -> Maybe Formula
addT _ _ = Nothing
instance (FORMULA a) => AddT a where {}
instance AddT Formula where
addT (Formula f) = addT f
instance AddT FInt where
addT (FInt 0) y = Just y
addT (FInt x) y
| isInt y = Just (mkInt (x + intVal y))
| otherwise = Nothing
instance AddT FSum where
addT (FSum xs) y
| isSum y = Just (mkSum (merge xs (argList y)))
| otherwise = Just (mkSum (merge xs [y]))
where
merge = (++)
instance AddT FLog where
addT (FLog x b) y
| isLog y && b == logBase y = Just (mkLog (mkPro [x,logExp y]) b)
| otherwise = Nothing
where
merge = (++)
isLog x = ty x == LOG
logBase x
| isLog x = head (tail (argList x))
logExp x
| isLog x = head (argList x)
-------------------------------------------------------------------------------
-- Test addition of formulas
main = print [ add (mkInt 78) (mkInt 110)
, add (mkInt 0) (mkVar "x")
, add (mkVar "x") (mkInt 0)
, add (mkVar "x") (mkVar "y")
, add (mkSum [mkInt 13,mkVar "x"]) (mkVar "y")
, add (mkLog (mkVar "x") (mkInt 10))
(mkLog (mkVar "y") (mkInt 10))
, add (mkLog (mkVar "x") (mkInt 10))
(mkLog (mkVar "y") (mkVar "e"))
]
include ($confdir ++ "/../vanilla-test.T")
-- Args to vt are: extra compile flags
-- extra run flags
-- expected process return value, if not zero
test "simplrun001" { vt("-O", "", "") }
test "simplrun002" { vt("-O", "", "") }
-- !!! Test filter fusion
-- In GHC 4.06, the filterFB rule was back to front, which
-- made this program hit the "error foo" case instead of
-- working fine.
module Main where
main :: IO ()
main = print (length (filter (not . foo)
(filter (const False) [Nothing])))
where foo (Just x) = x
foo _ = error "foo"
{-# OPTIONS -fglasgow-exts #-}
-- !!! A rules test
-- At one time the rule got too specialised a type:
--
-- _R "ffoo" forall {@ a1 v :: (a1, ((), ()))}
-- fst @ a1 @ () (sndSnd @ a1 @ () @ () v) = fst @ a1 @ ((), ()) v
module Main where
import IO
import PrelIOBase( unsafePerformIO )
sndSnd (a,(b,c)) = (a,c)
trace x y = unsafePerformIO (hPutStr stderr x >> hPutStr stderr "\n" >> return y)
{-# RULES "foo" forall v . fst (sndSnd v) = trace "Yes" (fst v) #-}
main :: IO ()
main = print (fst (sndSnd (True, (False,True))))
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