ghc 6.4 panic

[Sakari Jokinen]

The the bug is repeatable at least on my machine.

If there is a cure for this I would be happy to hear about it as I'll have 
to finish this for a course I'm taking.

EiffelSymtable.hs is included

 -Sakari
--------------------
ghc -fno-monomorphism-restriction --make parse_test.hs -o parse_test
Chasing modules from: parse_test.hs
Skipping  EiffelLexer      ( ./EiffelLexer.hs, ./EiffelLexer.o )
Skipping  EiffelLayout     ( ./EiffelLayout.hs, ./EiffelLayout.o )
Skipping  EiffelAST        ( ./EiffelAST.hs, ./EiffelAST.o )
Compiling EiffelSymtable   ( ./EiffelSymtable.hs, ./EiffelSymtable.o )
ghc-6.4: panic! (the `impossible' happened, GHC version 6.4):
	Unify.unifyTauTyLists: mismatched type lists!

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


make: *** [parse_test] Error 1

Compilation exited abnormally with code 2 at Thu Apr 28 16:34:29
-------------- next part --------------
module EiffelSymtable where
import qualified Data.IntMap as IMap
import qualified Data.Map as Map
import EiffelAST
import Data.List
import Data.Maybe

data Err = ErrNoBind {erruse::Int} 
	 | ErrNoSym {erruse::Int, errdef::Int }
	   deriving Show

class Valuable a where
    val::a -> b

data (Valuable a) => SymDict a = SymDict {idcounter:: Int, itot::IMap.IntMap a}
	       deriving Show

--
addsym::(Valuable a) =>  a -> SymDict a -> (SymDict a, Int)
addsym k a = ( SymDict {idcounter = i , 
			itot = IMap.insert i k $ itot a }, i)
    where i = (idcounter a) + 1

lookupsym::(Valuable a) =>Int -> SymDict a -> Maybe a
lookupsym i a = IMap.lookup i (itot a)

symdict :: (Valuable a) =>SymDict a
symdict = SymDict {idcounter = 0, itot = IMap.empty}

--outermost maybe means that it is possible that a type has not been bound to
--variable
data Symbol = SymbolFun { signature::[DefId] , rtype::Maybe DefId}
	    | SymbolType { typescopes::IMap.IntMap Scope, anyscope::Scope }
	    | SymbolVar { vtype::Maybe TypeId }
data SymTable = SymTable { syms::IMap.IntMap Symbol, 
			   binds::Bindings,
			   dict::SymDict,
			   symerrs::[Err]
			 }

type Bindings = IMap.IntMap (Maybe DefId)


type TypeId = Int -- refer to the id of the class in symtable
type UseId = Int -- refer to the usage of a symbol
type DefId = Int -- refer to a definition of a symbol in the symtable


type Use = SymTable -> Either UseId (UseId, DefId)
data Bind = Bind { runBind::Scope -> Use} 

data Scope = Scope { defs::[DefId] }

{-
define_member::ASTmember -> SymTable -> SymTable
define_type::ASTclass -> SymTable -> SymTable
-}

--
get_type_scope::DefId -> Symbol -> Scope
get_type_scope i s@(SymbolType _ _) = 
    maybe (anyscope s) (\c -> Scope $ (defs $?anyscope s) ++ (defs c)) $ 
	  IMap.lookup i $ typescopes s
get_type_scope i _ = error "Tried to take typescope from non type symbol"

--match sym ids in scope with i and return corresponding sym id
matchfun::[Maybe TypeId] -> UseId -> Scope -> SymTable -> Maybe DefId
matchfun sig i s t = find f $ defs s
    where f a = if is_fun a s 
		then name_cmp t a i &&?
			 (maybe (False) (\k -> sig_cmp sig $?map 
					 (\r -> vtype . fromJust $?IMap.lookup r?$?syms t ) $ 
					 signature k) $?IMap.lookup a $ syms t)?
		else False
	  sig_cmp ((Just k):ss) ((Just t):ts) = k == t --othrw. undefined types cannot bind
	  sig_cmp _ _ = False

match::UseId -> Scope -> SymTable -> Maybe DefId
match i s t = find f (defs s)
    where f a = name_cmp t a i && is_var a t

name_cmp d i j = (val $?fromJust $?lookupsym i $ dict d ) == 
		 (val $?fromJust $?lookupsym j $ dict d)

is_sym_type st f a = maybe False (\s -> maybe False (\k -> f k) s) $?Map.lookup a $ syms st
is_var a st = is_sym_type st (\s -> case s of 
			SymbolVar _ -> True
			otherwise -> False) a 
is_fun a st = is_sym_type st (\s -> case s of 
			SymbolFun _ _ -> True
			otherwise -> False) a 
--sentinel binds for the bottom of the bind tree
bindvar::Int -> Bind
bindvar i = Bind (\s t -> maybe (Left i) 
		  (\k -> Right (i, k) ) $?
		  match i s t)

bindfun::Int -> [Maybe TypeId] -> Bind
bindfun i sig = Bind  (\s t -> maybe (Left i) 
		       (\k -> Right (i, k)) $?
		       matchfun i sig s t)


--solve_binds
solve_binds::[Bind] -> SymTable -> SymTable
solve_binds []?s = s
solve_binds (b:bs) s = case runBind b c s of
					  Left u -> r $?s {symerrs = (ErrNoBind u) : (symerrs s), 
							   binds = IMap.insert (u, Nothing) $ 
							   binds s}
					  Right u -> r $ s {binds = IMap.insert u $ binds s}
    where c = Scope []
	  r s = solve_binds bs s


--add scope in which to bind
bind_scope::Scope -> Bind -> Bind
bind_scope s b = Bind w 
    where w = \t s' -> case runBind b s t of 
					  Left i -> runBind b s' t
					  Right t' -> Right t'

--bind in the scope of the type of expression tagged with current type
bind_from_expr::ASTexpr -> Maybe TypeId -> Bind -> Bind
bind_from_expr x parent b = Bind w
    where w = \ s t -> case runBind b s t of
				     Left i -> maybe (Left i) (\p -> w' i p s t) $
					       solve_type x t
				     Right u -> Right u
	  w' i p s t = maybe (Left i) 
		       (\e -> runBind b e t) $ get_type_scope parent p 

--returns the sym id of the type of expression
solve_type::ASTexpr -> SymTable -> Maybe TypeId
solve_type (ASTexprGroup x) t = solve_type x t
solve_type (ASTexprApp f x) t = get_type f t
solve_type (ASTexprId i) t = get_type i t
solve_type (ASTexprIntLit k ) t = error "todo: literal solve type"

--returns the sym id of the type of i
get_type::UseId -> SymTable -> Maybe TypeId
get_type i t = do
	       j <- IMap.lookup i $ binds t
	       k <- IMap.lookup j $ syms t
	       let w f@(SymbolFun a b) = do
					 a <- rtype f 
					 b <- IMap.lookup a $ syms t
					 vtype b
		   w f@(SymbolVar a) = vtype f
		   w _ = error "Tried to get type of a type" 
	       w k