diff options
Diffstat (limited to 'testsuite/tests/programs/andre_monad/Main.hs')
| -rw-r--r-- | testsuite/tests/programs/andre_monad/Main.hs | 89 |
1 files changed, 89 insertions, 0 deletions
diff --git a/testsuite/tests/programs/andre_monad/Main.hs b/testsuite/tests/programs/andre_monad/Main.hs new file mode 100644 index 0000000000..7e3dda6362 --- /dev/null +++ b/testsuite/tests/programs/andre_monad/Main.hs @@ -0,0 +1,89 @@ +-- Evaluator in a monad: with execution counts +-- Phil Wadler, 11 October 1991 + +-- Types are optional. Some must be commented out to +-- work around a bug in Gofer. + +-- The count monad + +type M a = (a, Int) + +unit :: a -> M a +unit a = (a, 0) + +bind :: M a -> (a -> M b) -> M b +m `bind` k = case m of + (a,i) -> case k a of + (b,j) -> (b,i+j) + +-- disp :: Text a => M a -> String +disp (a,i) = show a ++ "\nCount: " ++ show i + +tick :: M () +tick = ((), 1) + +-- The evaluator +-- Lines with * are only change from evalIdent + +data Op = Add | Sub | Mul | Quo +data Term = Con Int | Bin Op Term Term + +eval :: Term -> M Int +eval (Con i) = unit i +eval (Bin op u v) = eval u `bind` (\a -> + eval v `bind` (\b -> + go op a b `bind` (\c -> -- * + tick `bind` (\ () -> -- * + unit c)))) -- * + +go :: Op -> Int -> Int -> M Int +go Add a b = unit (a+b) +go Sub a b = unit (a-b) +go Mul a b = unit (a*b) +go Quo a b = unit (a `quot` b) -- WDP: was "div" + +test :: Term -> String +test t = disp (eval t) + +-- Test data + +add, sub, mul, quo :: Term -> Term -> Term +u `add` v = Bin Add u v +u `sub` v = Bin Sub u v +u `mul` v = Bin Mul u v +u `quo` v = Bin Quo u v + +term0,term1,term2 :: Term +term0 = Con 6 `mul` Con 9 +term1 = (Con 4 `mul` Con 13) `add` Con 2 +term2 = (Con 1 `quo` Con 2) `add` Con 2 +term3 = (((((((((((((((((((((((((((((((( + (((((((((((((((((((((((((((((( + Con 7777 `mul` Con 13) `quo` Con 13) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + `mul` Con 755) `quo` Con 755) `mul` Con 333) + `quo` Con 755) `mul` Con 755) `mul` Con 333) + +sb 0 = term2 +sb n = if (n `mod` 2) == 0 + then term2 `add` (sb (n-1)) + else term2 `sub` (sb (n-1)) + +main = print (show (eval (sb 5000))) |