GHC hangs/takes an exponential amount of time with simple program

This was discovered when trying to compile xml-conduit. Here is the standalone test case with a few comments indicating how to make it compile.

The program compiles with ghc-7.10.2 but fails with HEAD.

{-# LANGUAGE RankNTypes #-}
module Hang where
import Control.Monad
import Data.Char

data Event
  = EventBeginDocument
  | EventEndDocument
  | EventBeginDoctype
  | EventEndDoctype
  | EventInstruction
  | EventBeginElement
  | EventEndElement
  | EventContent Content
  | EventComment
  | EventCDATA

data Content
  = ContentText String
  | ContentEntity String


peek :: Monad m => Consumer a m (Maybe a)
peek = undefined

type Consumer i m r = forall o. ConduitM i o m r

tag :: forall m a b c o . Monad m =>
    ConduitM Event o m (Maybe c)
tag = do
    _ <- dropWS
    return undefined
  where
-- Add this and it works
--    dropWS :: Monad m => ConduitM Event o m (Maybe Event)
    dropWS = do
-- Swap these two lines and it works
--        let x = undefined
        x <- peek
        let isWS =
                case x of
                    -- Remove some of these and it works
                    Just EventBeginDocument -> True
                    Just EventEndDocument -> True
                    Just EventBeginDoctype{} -> True
                    Just EventEndDoctype -> True
                    Just EventInstruction{} -> True
                    Just EventBeginElement{} -> False
                    Just EventEndElement{} -> False
                    Just (EventContent (ContentText t))
                        | all isSpace t -> True
                        | otherwise -> False
                    Just (EventContent ContentEntity{}) -> False
                    Just EventComment{} -> True
                    Just EventCDATA{} -> False
                    Nothing -> False
        if isWS then dropWS else return x

-- Inlined Instances

instance Functor (ConduitM i o m) where
    fmap f (ConduitM c) = ConduitM $ \rest -> c (rest . f)

instance Applicative (ConduitM i o m) where
    pure x = ConduitM ($ x)
    {-# INLINE pure #-}
    (<*>) = ap
    {-# INLINE (<*>) #-}

instance Monad (ConduitM i o m) where
    return = pure
    ConduitM f >>= g = ConduitM $ \h -> f $ \a -> unConduitM (g a) h

instance Monad m => Functor (Pipe l i o u m) where
    fmap = liftM
    {-# INLINE fmap #-}

instance Monad m => Applicative (Pipe l i o u m) where
    pure = Done
    {-# INLINE pure #-}
    (<*>) = ap
    {-# INLINE (<*>) #-}

instance Monad m => Monad (Pipe l i o u m) where
    return = pure
    {-# INLINE return #-}

    HaveOutput p c o >>= fp = HaveOutput (p >>= fp)            c          o
    NeedInput p c    >>= fp = NeedInput  (p >=> fp)            (c >=> fp)
    Done x           >>= fp = fp x
    PipeM mp         >>= fp = PipeM      ((>>= fp) `liftM` mp)
    Leftover p i     >>= fp = Leftover   (p >>= fp)            i

newtype ConduitM i o m r = ConduitM
    { unConduitM :: forall b.
                    (r -> Pipe i i o () m b) -> Pipe i i o () m b
    }

data Pipe l i o u m r =
    HaveOutput (Pipe l i o u m r) (m ()) o
  | NeedInput (i -> Pipe l i o u m r) (u -> Pipe l i o u m r)
  | Done r
  | PipeM (m (Pipe l i o u m r))
  | Leftover (Pipe l i o u m r) l

Trac metadata

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