ghc/tests/typecheck/should_run/tcrun010.hs

   1 {-# OPTIONS -fglasgow-exts #-}
   2
   3 -- !!! Functional dependencies
   4 -- This one gave "zonkIdOcc:  FunDep_a11w" in earlier days
   5
   6 module Main (main) where
   7
   8 data ERR a b = EOK a | ERR b deriving (Show)
   9 data Error   = No | Notatall deriving (Show, Eq)
  10
  11
  12 class MonadErr m e | m -> e where
  13    aerturn ::           e   -> m a
  14    areturn ::           a   -> m a
  15    acatch  ::           a   -> (a -> m b) -> (e -> m b) -> m b
  16    (>>>=)  ::           m a -> (a -> m b) -> m b
  17    (>>>)   ::           m a -> m b        -> m b
  18
  19 data BP a = BP (Int -> (ERR a Error, Int))
  20
  21 instance MonadErr BP Error where
  22    aerturn k             = BP $ \s  -> (ERR k, s)
  23    areturn k             = BP $ \s  -> (EOK k, s)
  24    acatch  k try handler = BP $ \s  -> let BP try'     = try  k
  25                                            (r,s1)      = try' s
  26                                            (BP c2, s2) = case r of
  27                                                            EOK r -> (areturn r, s1)
  28                                                            ERR r -> (handler r, s)
  29                                        in  c2 s2
  30    a >>> b =  a >>>= \_ -> b
  31
  32    (BP c1) >>>= fc2      = BP $ \s0 -> let (r,s1) = c1 s0
  33                                            BP c2 = case r of
  34                                                      EOK r -> fc2 r
  35                                                      ERR r -> BP (\s -> (ERR r, s))
  36                                        in c2 s1
  37
  38 run_BP :: Int -> BP a -> (ERR a Error, Int)
  39 run_BP st (BP bp) = bp st
  40
  41 foo :: (ERR Int Error, Int)
  42 foo = run_BP 111 (aerturn No)
  43
  44 main = print (show foo)