ghc/tests/programs/andre_monad/Main.hs

   1 -- Evaluator in a monad: with execution counts
   2 -- Phil Wadler, 11 October 1991
   3
   4 -- Types are optional.  Some must be commented out to
   5 -- work around a bug in Gofer.
   6
   7 -- The count monad
   8
   9 type  M a               =  (a, Int)
  10
  11 unit                    :: a -> M a
  12 unit a                  =  (a, 0)
  13
  14 bind                    :: M a -> (a -> M b) -> M b
  15 m `bind` k              =  case m of
  16                              (a,i) -> case k a of
  17                                         (b,j) -> (b,i+j)
  18
  19 -- disp                 :: Text a => M a -> String
  20 disp (a,i)              =  show a ++ "\nCount: " ++ show i
  21
  22 tick                    :: M ()
  23 tick                    =  ((), 1)
  24
  25 -- The evaluator
  26 -- Lines with * are only change from evalIdent
  27
  28 data  Op                =  Add | Sub | Mul | Quo
  29 data  Term              =  Con Int | Bin Op Term Term
  30
  31 eval                    :: Term -> M Int
  32 eval (Con i)            =  unit i
  33 eval (Bin op u v)       =  eval u     `bind` (\a  ->
  34                            eval v     `bind` (\b  ->
  35                            go op a b  `bind` (\c  ->    -- *
  36                            tick       `bind` (\ () ->   -- *
  37                            unit c))))                   -- *
  38
  39 go                      :: Op -> Int -> Int -> M Int
  40 go Add a b              =  unit (a+b)
  41 go Sub a b              =  unit (a-b)
  42 go Mul a b              =  unit (a*b)
  43 go Quo a b              =  unit (a `quot` b) -- WDP: was "div"
  44
  45 test                    :: Term -> String
  46 test t                  =  disp (eval t)
  47
  48 -- Test data
  49
  50 add, sub, mul, quo      :: Term -> Term -> Term
  51 u `add` v               =  Bin Add u v
  52 u `sub` v               =  Bin Sub u v
  53 u `mul` v               =  Bin Mul u v
  54 u `quo` v               =  Bin Quo u v
  55
  56 term0,term1,term2       :: Term
  57 term0                   =  Con 6 `mul` Con 9
  58 term1                   =  (Con 4 `mul` Con 13) `add` Con 2
  59 term2                   =  (Con 1 `quo` Con 2) `add` Con 2
  60 term3                   =  ((((((((((((((((((((((((((((((((
  61                            ((((((((((((((((((((((((((((((
  62                                  Con 7777 `mul` Con  13) `quo` Con  13)
  63                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  64                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  65                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  66                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  67                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  68                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  69                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  70                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  71                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  72                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  73                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  74                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  75                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  76                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  77                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  78                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  79                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  80                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  81                            `mul` Con 755) `quo` Con 755) `mul` Con 333)
  82                            `quo` Con 755) `mul` Con 755) `mul` Con 333)
  83
  84 sb 0 = term2
  85 sb n = if (n `mod` 2) == 0
  86        then term2 `add` (sb (n-1))
  87        else term2 `sub` (sb (n-1))
  88
  89 main = print (show (eval (sb 5000)))