[GHC] #13410: GHC HEAD regression: Template variable unbound in rewrite rule

[GHC]

#13410: GHC HEAD regression: Template variable unbound in rewrite rule
-------------------------------------+-------------------------------------
        Reporter:  RyanGlScott       |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  highest           |            Milestone:  8.2.1
       Component:  Compiler          |              Version:  8.1
      Resolution:                    |             Keywords:  JoinPoints
Operating System:  Unknown/Multiple  |         Architecture:
 Type of failure:  Compile-time      |  Unknown/Multiple
  crash or panic                     |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by RyanGlScott):

 I reduced the file from ~400 lines to ~150 lines:

 {{{#!hs
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}

 module Data.Vector.Hybrid.Internal (Vector) where

 import Control.Monad (liftM2)
 import Data.Functor.Identity (Identity(..))
 import GHC.ST (ST, runST)
 import Text.Read (ReadPrec, readPrec)

 -----

 class Monad m => PrimMonad m where
   type PrimState m

 instance PrimMonad (ST s) where
   type PrimState (ST s) = s

 class GMVector v a where
   gmbasicLength      :: v s a -> Int
   gmbasicUnsafeSlice :: Int -> Int -> v s a -> v s a
   gmbasicUnsafeNew   :: PrimMonad m => Int -> m (v (PrimState m) a)
   gmbasicUnsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m
 ()

 type family GMutable (v :: * -> *) :: * -> * -> *

 class GMVector (GMutable v) a => GVector v a where
   gbasicUnsafeFreeze :: PrimMonad m => GMutable v (PrimState m) a -> m (v
 a)

 data Step s a where
   Yield :: a -> s -> Step s a

 instance Functor (Step s) where
   {-# INLINE fmap #-}
   fmap f (Yield x s) = Yield (f x) s

 data Stream m a = forall s. Stream (s -> m (Step s a)) s
 data Chunk v a = Chunk Int (forall m. (PrimMonad m, GVector v a) =>
 GMutable v (PrimState m) a -> m ())
 data New v a = New { newrun :: forall s. ST s (GMutable v s a) }
 type MBundle m v a = Stream m (Chunk v a)
 type Bundle v a = MBundle Identity v a

 mbfromStream :: Monad m => Stream m a -> MBundle m v a
 {-# INLINE mbfromStream #-}
 mbfromStream (Stream step t) = Stream step' t
   where
     step' s = do r <- step s
                  return $ fmap (\x -> Chunk 1 (\v -> gmbasicUnsafeWrite v
 0 x)) r

 mbunsafeFromList :: Monad m => [a] -> MBundle m v a
 {-# INLINE [1] mbunsafeFromList #-}
 mbunsafeFromList xs = mbfromStream (sfromList xs)

 blift :: Monad m => Bundle v a -> MBundle m v a
 {-# INLINE [1] blift #-}
 blift (Stream vstep t) = Stream (return . runIdentity . vstep) t

 sfromList :: Monad m => [a] -> Stream m a
 {-# INLINE sfromList #-}
 sfromList zs = Stream step zs
   where
     step (x:xs) = return (Yield x xs)
     step _ = undefined

 sfoldlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a
 {-# INLINE [1] sfoldlM #-}
 sfoldlM m w (Stream step t) = foldlM_loop w t
   where
     foldlM_loop z s
       = do
           r <- step s
           case r of
             Yield x s' -> do { z' <- m z x; foldlM_loop z' s' }

 gmvunstream :: (PrimMonad m, GVector v a)
             => Bundle v a -> m (GMutable v (PrimState m) a)
 {-# INLINE [1] gmvunstream #-}
 gmvunstream s = gmvmunstreamUnknown (blift s)

 gmvmunstreamUnknown :: (PrimMonad m, GVector v a)
                     => MBundle m v a -> m (GMutable v (PrimState m) a)
 {-# INLINE gmvmunstreamUnknown #-}
 gmvmunstreamUnknown s
   = do
       v <- gmbasicUnsafeNew 0
       (_, _) <- sfoldlM copyChunk (v,0) s
       return undefined
   where
     {-# INLINE [0] copyChunk #-}
     copyChunk (v,i) (Chunk n f)
       = do
           let j = i+n
           v' <- if gmbasicLength v < j
                   then gmbasicUnsafeNew undefined
                   else return v
           f (gmbasicUnsafeSlice i n v')
           return (v',j)

 newunstream :: GVector v a => Bundle v a -> New v a
 {-# INLINE [1] newunstream #-}
 newunstream s = s `seq` New (gmvunstream s)

 gnew :: GVector v a => New v a -> v a
 {-# INLINE [1] gnew #-}
 gnew m = m `seq` runST (gbasicUnsafeFreeze =<< newrun m)

 gunstream :: GVector v a => Bundle v a -> v a
 {-# INLINE gunstream #-}
 gunstream s = gnew (newunstream s)

 gfromList :: GVector v a => [a] -> v a
 {-# INLINE gfromList #-}
 gfromList = gunstream . mbunsafeFromList

 greadPrec :: (GVector v a, Read a) => ReadPrec (v a)
 {-# INLINE greadPrec #-}
 greadPrec = do
   xs <- readPrec
   return (gfromList xs)

 -----

 data MVector :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> * where
   MV :: !(u s a) -> !(v s b) -> MVector u v s (a, b)

 instance (GMVector u a, GMVector v b) => GMVector (MVector u v) (a, b)
 where
   gmbasicLength (MV ks _) = gmbasicLength ks
   gmbasicUnsafeSlice s e (MV ks vs) = MV (gmbasicUnsafeSlice s e ks)
 (gmbasicUnsafeSlice s e vs)

   gmbasicUnsafeNew n = liftM2 MV (gmbasicUnsafeNew n) (gmbasicUnsafeNew n)
   -- Removing this INLINE pragma makes it compile
   {-# INLINE gmbasicUnsafeNew #-}

   gmbasicUnsafeWrite (MV ks vs) n (k,v) = do
     gmbasicUnsafeWrite ks n k
     gmbasicUnsafeWrite vs n v

 data Vector :: (* -> *) -> (* -> *) -> * -> *

 type instance GMutable (Vector u v) = MVector (GMutable u) (GMutable v)

 instance (GVector u a, GVector v b) => GVector (Vector u v) (a, b) where
   gbasicUnsafeFreeze = undefined

 instance (GVector u a, GVector v b, Read a, Read b, c ~ (a, b)) => Read
 (Vector u v c) where
   readPrec = greadPrec
 }}}

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