ghc/tests/programs/jon_polycase/Foo.lhs

   1 {-
   2         Date: Wed, 3 Sep 1997 10:25:35 +0200 (MET DST)
   3         From: Jon Mountjoy <jon@wins.uva.nl>
   4
   5 Hello Bug Hunters,
   6
   7 The following program (rather condensed as it comes from something
   8 much larger), crashes the compiler. I am using ghc-2.05 on a Solaris
   9 box, with one or two patches(including the WwLib one which Simon gave
  10 me, but this error occured before applying this patch).
  11
  12 It seems to be some rather subtle dependency problem.  Compiling with
  13 -O solves the problem, compiling with ghc -c Foo.lhs should highlight
  14 it.  The error message is appended below the file.  What are the new
  15 "discarding polymorphic case" warnings about?
  16
  17 If you change any line in reallyFlatten, the program compiles fine.
  18 Likewise if you change the type of LinearCode to Int!
  19
  20 -}
  21
  22 > -- SNIP START
  23
  24 > module Foo where
  25
  26 > import Array
  27 > import Monad
  28
  29 > reallyFlatten ::  Int -> Int -> Interpreter ()
  30 > reallyFlatten x t
  31 >  = do
  32 >     let f  = goo x
  33 >     out $ show x
  34 >     setIStatus (IFlattened f f)
  35 >     return ()
  36
  37 > goo :: Int -> LinearCode
  38 > goo = \x -> listArray (0,1) []
  39
  40 %---------------------------------------------------------------------
  41
  42 > type LinearCode = Array Int Int
  43
  44 > data InterpStatus = IFlattened !LinearCode !LinearCode
  45 > data SM = SM { interpStatus :: InterpStatus }
  46 > initialState = SM { interpStatus = IFlattened undefined undefined }
  47
  48 > newtype Interpreter a = RepInterp ((SM,Int) -> IO (Error ((SM,Int),a)))
  49 > getRepInterp (RepInterp a ) = a
  50
  51 > instance Functor Interpreter where
  52 >  map f (RepInterp intp )
  53 >   = RepInterp (\s -> case intp s of
  54 >                        g -> g >>= \q ->
  55 >                         case q of
  56 >                          Error mes  -> return $ Error mes
  57 >                          Ok (s',a') -> return $ Ok (s',f a'))
  58
  59 > instance Monad Interpreter where
  60 >  return x = RepInterp (\s -> return (Ok (s,x)))
  61 >  (RepInterp intp) >>= g
  62 >    = RepInterp(\s -> case intp s of
  63 >                       p -> p >>= \q ->
  64 >                        case q of
  65 >                         Error mes  -> return $ Error mes
  66 >                         Ok (s',x') -> getRepInterp (g x') s' )
  67
  68 > instance OutputMonad Interpreter where
  69 >  out s = RepInterp (\st -> putStr s >>
  70 >                            return (Ok (st,())))
  71
  72 > updateSM :: (SM -> SM) -> Interpreter SM
  73 > updateSM f = RepInterp (\s@(sm,ty) -> return $ Ok ((f sm,ty), sm))
  74
  75 > setIStatus :: InterpStatus -> Interpreter InterpStatus
  76 > setIStatus is = updateSM (\sm -> sm {interpStatus = is}) >>=
  77 >                 return.interpStatus
  78
  79 > data Error a = Ok a | Error String
  80 >
  81 > class Monad m => OutputMonad m  where
  82 >   out      :: String -> m ()
  83 > instance OutputMonad IO where
  84 >  out s = catch (putStr s) (\_ ->  fail $userError "Oh MY")