[GHC] #11339: Possible type-checker regression in GHC 8.0

[GHC]

#11339: Possible type-checker regression in GHC 8.0
-------------------------------------+-------------------------------------
        Reporter:  hvr               |                Owner:  simonpj
            Type:  bug               |               Status:  new
        Priority:  highest           |            Milestone:  8.0.2
       Component:  Compiler (Type    |              Version:  8.0.1-rc1
  checker)                           |
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
                                     |  Unknown/Multiple
 Type of failure:  None/Unknown      |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by RyanGlScott):

 This also affects [https://github.com/ekmett/machines machines].
 [https://github.com/ekmett/machines/blob/4999036bdefe286e940dc70bf83413724d3927d0/src/Data/Machine/Fanout.hs#L25-L56
 This is the code] that is affected (simplified version reproduced below):

 {{{#!hs
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 -- Simplified code from the machines package
 module Data.Machine.Fanout where

 class Semigroup a where
     (<>) :: a -> a -> a
     sconcat :: NonEmpty a -> a

 data NonEmpty a = a :| [a]

 -- | Witnessed type equality
 data Is a b where
   Refl :: Is a a

 -- | This is the base functor for a 'Machine' or 'MachineT'.
 --
 -- Note: A 'Machine' is usually constructed from 'Plan', so it does not
 need to be CPS'd.
 data Step k o r
   = Stop
   | Yield o r
   | forall t. Await (t -> r) (k t) r

 -- | A 'MachineT' reads from a number of inputs and may yield results
 before stopping
 -- with monadic side-effects.
 newtype MachineT m k o = MachineT { runMachineT :: m (Step k o (MachineT m
 k o)) }

 -- | A @'ProcessT' m a b@ is a stream transducer that can consume values
 of type @a@
 -- from its input, and produce values of type @b@ and has side-effects in
 the
 -- 'Monad' @m at .
 type ProcessT m a b = MachineT m (Is a) b

 continue :: ([b] -> r) -> [(a -> b, b)] -> Step (Is a) o r
 continue _ [] = Stop
 continue f ws = Await (f . traverse fst ws) Refl (f $ map snd ws)

 -- | Pack a 'Step' of a 'Machine' into a 'Machine'.
 encased :: Monad m => Step k o (MachineT m k o) -> MachineT m k o
 encased = MachineT . return

 semigroupDlist :: Semigroup a => ([a] -> [a]) -> Maybe a
 semigroupDlist f = case f [] of
   [] -> Nothing
   x:xs -> Just $ sconcat (x:|xs)

 -- | Share inputs with each of a list of processes in lockstep. Any
 -- values yielded by the processes are combined into a single yield
 -- from the composite process.
 fanout :: (Functor m, Monad m, Semigroup r)
        => [ProcessT m a r] -> ProcessT m a r
 fanout = MachineT . go id id
   where
     go waiting acc [] = case waiting [] of
       ws -> return . maybe k (\x -> Yield x $ encased k) $ semigroupDlist
 acc
         where k = continue fanout ws
     go waiting acc (m:ms) = runMachineT m >>= \v -> case v of
       Stop           -> go waiting acc ms
       Yield x k      -> go waiting (acc . (x:)) (k:ms)
       Await f Refl k -> go (waiting . ((f, k):)) acc ms

 -- | Share inputs with each of a list of processes in lockstep. If
 -- none of the processes yields a value, the composite process will
 -- itself yield 'mempty'. The idea is to provide a handle on steps
 -- only executed for their side effects. For instance, if you want to
 -- run a collection of 'ProcessT's that await but don't yield some
 -- number of times, you can use 'fanOutSteps . map (fmap (const ()))'
 -- followed by a 'taking' process.
 fanoutSteps :: (Functor m, Monad m, Monoid r)
             => [ProcessT m a r] -> ProcessT m a r
 fanoutSteps = MachineT . go id id
   where
     go waiting acc [] = case (waiting [], mconcat (acc [])) of
       (ws, xs) -> return . Yield xs $ encased (continue fanoutSteps ws)
     go waiting acc (m:ms) = runMachineT m >>= \v -> case v of
       Stop           -> go waiting acc ms
       Yield x k      -> go waiting (acc . (x:)) (k:ms)
       Await f Refl k -> go (waiting . ((f, k):)) acc ms
 }}}

 The workaround is to change the definitions of `fanout` and `fanoutSteps`
 to the following:

 {{{#!hs
 -- | Share inputs with each of a list of processes in lockstep. Any
 -- values yielded by the processes are combined into a single yield
 -- from the composite process.
 fanout :: forall m a r. (Functor m, Monad m, Semigroup r)
        => [ProcessT m a r] -> ProcessT m a r
 fanout = MachineT . go id id
   where
     go :: ([(a -> ProcessT m a r, ProcessT m a r)]
        -> [(a -> ProcessT m a r, ProcessT m a r)])
        -> ([r] -> [r])
        -> [ProcessT m a r]
        -> m (Step (Is a) r (ProcessT m a r))
     go waiting acc [] = case waiting [] of
       ws -> return . maybe k (\x -> Yield x $ encased k) $ semigroupDlist
 acc
         where k = continue fanout ws
     go waiting acc (m:ms) = runMachineT m >>= \v -> case v of
       Stop           -> go waiting acc ms
       Yield x k      -> go waiting (acc . (x:)) (k:ms)
       Await f Refl k -> go (waiting . ((f, k):)) acc ms

 -- | Share inputs with each of a list of processes in lockstep. If
 -- none of the processes yields a value, the composite process will
 -- itself yield 'mempty'. The idea is to provide a handle on steps
 -- only executed for their side effects. For instance, if you want to
 -- run a collection of 'ProcessT's that await but don't yield some
 -- number of times, you can use 'fanOutSteps . map (fmap (const ()))'
 -- followed by a 'taking' process.
 fanoutSteps :: forall m a r. (Functor m, Monad m, Monoid r)
             => [ProcessT m a r] -> ProcessT m a r
 fanoutSteps = MachineT . go id id
   where
     go :: ([(a -> ProcessT m a r, ProcessT m a r)]
        -> [(a -> ProcessT m a r, ProcessT m a r)])
        -> ([r] -> [r])
        -> [ProcessT m a r]
        -> m (Step (Is a) r (ProcessT m a r))
     go waiting acc [] = case (waiting [], mconcat (acc [])) of
       (ws, xs) -> return . Yield xs $ encased (continue fanoutSteps ws)
     go waiting acc (m:ms) = runMachineT m >>= \v -> case v of
       Stop           -> go waiting acc ms
       Yield x k      -> go waiting (acc . (x:)) (k:ms)
       Await f Refl k -> go (waiting . ((f, k):)) acc ms
 }}}

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/11339#comment:12>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler