GitLab

1. 0.1 and HEAD accept the following pair of modules, but the 7.0 branch panics (cut down from iteratee; iteratee-mtl and uni-htk have similar panics):

{-# LANGUAGE Rank2Types, DeriveDataTypeable #-}

module A where

import Control.Exception (SomeException)

class NullPoint c where
  empty :: c
class NullPoint c => Nullable c where
  nullC :: c -> Bool

data Stream c = EOF | Chunk c
  deriving (Show)

newtype Iteratee s m a = Iteratee{ runIter :: forall r.
          (a -> Stream s -> m r) ->
          ((Stream s -> Iteratee s m a) -> Maybe SomeException -> m r) ->
          m r}

icont :: (Stream s -> Iteratee s m a) -> Maybe SomeException -> Iteratee s m a
icont k e = Iteratee $ \_ onCont -> onCont k e

instance (Monad m, Nullable s) => Monad (Iteratee s m) where
  {-# INLINE return #-}
  return x = Iteratee $ \onDone _ -> onDone x (Chunk empty)
  {-# INLINE (>>=) #-}
  m >>= f = Iteratee $ \onDone onCont ->
     let m_done a (Chunk s)
           | nullC s      = runIter (f a) onDone onCont
         m_done a stream = runIter (f a) (const . flip onDone stream) f_cont
           where f_cont k Nothing = runIter (k stream) onDone onCont
                 f_cont k e       = onCont k e
     in runIter m m_done (onCont . ((>>= f) .))

module B (throwErr, joinI) where

import A

import Control.Exception
import Data.Maybe

excDivergent :: SomeException
excDivergent = undefined

throwErr :: (Monad m) => SomeException -> Iteratee s m a
throwErr e = icont (const (throwErr e)) (Just e)

joinI ::
 (Monad m, Nullable s) =>
  Iteratee s m (Iteratee s' m a)
  -> Iteratee s m a
joinI = (>>=
  \inner -> Iteratee $ \od oc ->
  let on_done  x _        = od x (Chunk empty)
      on_cont  k Nothing  = runIter (k EOF) on_done on_cont'
      on_cont  _ (Just e) = runIter (throwErr e) od oc
      on_cont' _ e        = runIter (throwErr (fromMaybe excDivergent e)) od oc
  in runIter inner on_done on_cont)

$ ghc --make -O B
[1 of 2] Compiling A                ( A.hs, A.o )
[2 of 2] Compiling B                ( B.hs, B.o )
ghc-stage2: panic! (the 'impossible' happened)
  (GHC version 7.0.1.20110203 for x86_64-unknown-linux):
        urk! lookup local fingerprint main:B.throwErr{v rR3}

Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug

Trac metadata

Trac field	Value
Version	7.0.1
Type	Bug
TypeOfFailure	OtherFailure
Priority	highest
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture