compiler bug in ghc-6.4 (building a class declaration with TH)

[Benjamin Franksen]

This is command and output:

> ghc -fth -ddump-splices --make TestBuffers.hs
Chasing modules from: TestBuffers.hs
Compiling Buffers          ( ./Buffers.hs, ./Buffers.o )
Compiling Main             ( TestBuffers.hs, TestBuffers.o )
Loading package base-1.0 ... linking ... done.
Loading package haskell98-1.0 ... linking ... done.
Loading package template-haskell-1.0 ... linking ... done.
TestBuffers.hs:1:0:
    TestBuffers.hs:1:0: Splicing declarations
        mkBufferClasses 12
      ======>
        class HasZero f where { zero :: a; emptyBag }
        class HasOne f where {ghc-6.4: panic! (the `impossible' 
happened, GHC version 6.4):
        hsSyn/Convert.lhs:(339,8)-(350,91): Non-exhaustive patterns in 
function trans


Please report it as a compiler bug to glasgow-haskell-bugs at haskell.org,
or http://sourceforge.net/projects/ghc/.

I attached the two (short) source files.

Ben
-------------- next part --------------
module Buffers where

import Language.Haskell.TH
import Control.Monad (when)
import Data.Char (toUpper)

numNames = ["zero","one","two","three","four","five",
            "six","seven","eight","nine","ten","eleven","twelve"]
            ++ map show [13..]

numNames' = [toUpper x : xs | (x:xs) <- front] ++ back
  where (front,back) = splitAt 13 numNames

mkBufferType :: String -> [Int] -> Q [Dec]
mkBufferType name quantities = do
  let tc_name = mkName name
  let tv_name = mkName "a"
  let tvars = [tv_name]
  let dcs = [NormalC (mkName (name++(numNames'!!i))) (replicate i (NotStrict, VarT tv_name)) | i <- quantities]
  let derivs = []
  return [DataD [] tc_name tvars dcs derivs]

mkBufferClasses :: Int -> Q [Dec]
mkBufferClasses max = do
    let class_name i = mkName ("Has"++(numNames'!!i))
    let ctx = []
    let tv_name_coll = mkName "f"
    let tv_name_elem = mkName "a"
    let tvars = [tv_name_coll]
    let fundeps = []
    let meth_name i = mkName (numNames !! i)
    let meth_type i = type_nx_to_y i (VarT tv_name_elem) (VarT tv_name_coll)
    let meth_decls i = [SigD (meth_name i) (meth_type i)]
    return [ClassD ctx (class_name i) tvars fundeps (meth_decls i) | i <- [0..max]]
  where
    type_nx_to_y n xt yt
      | n == 0    = xt
      | n > 0     = AppT ArrowT (AppT xt (type_nx_to_y (n-1) xt yt))
      | otherwise = error "Buffers.type_nx_to_y: n < 0"

-- class HasOne c where
--   one :: e -> c e
-------------- next part --------------
import Buffers

$(mkBufferClasses 12)

$(mkBufferType "BufferZeroToTen" [0..10])
$(mkBufferType "BufferThreeToFive" [3..5])
$(mkBufferType "BufferTwoSixFour" [2,6,4])