[Instead of substitutions, use a mutable reference cell in Tyvars to keep track of unifications. 
John Meacham <john@repetae.net>**20050505023816] hunk ./DataConstructors.hs 44
-tipe (TGen n (Tyvar _ _ k)) = EVar (tVr ((n + 1) * 2 ) (kind k))
-tipe (TVar (Tyvar _ n k)) = error "tipe': Tyvar"
+tipe (TGen n (Tyvar { tyvarKind = k })) = EVar (tVr ((n + 1) * 2 ) (kind k))
+tipe (TVar Tyvar {}) = error "tipe': Tyvar"
hunk ./E/FromHs.hs 58
-tipe (TVar (Tyvar _ n k)) = EVar (tVr (lt n) (kind k))
-tipe (TGen _ (Tyvar _ n k)) = EVar (tVr (lt n) (kind k))
+tipe (TVar (Tyvar _ n k _)) = EVar (tVr (lt n) (kind k))
+tipe (TGen _ (Tyvar _ n k _)) = EVar (tVr (lt n) (kind k))
hunk ./E/FromHs.hs 97
-    mp fn (((Tyvar _ n k)):rs) t = fn (tVr (lt n) (kind k)) (mp fn rs t)
+    mp fn (((Tyvar _ n k _)):rs) t = fn (tVr (lt n) (kind k)) (mp fn rs t)
hunk ./E/FromHs.hs 103
-    mp fn (((Tyvar _ n k)):rs) t = fn (tVr (lt n) (kind k)) (mp fn rs t)
+    mp fn (((Tyvar _ n k _)):rs) t = fn (tVr (lt n) (kind k)) (mp fn rs t)
hunk ./FrontEnd/Class.hs 435
-toType (HsTyVar n, k) = TVar $ tyvar n k
+toType (HsTyVar n, k) = TVar $ tyvar n k Nothing
hunk ./FrontEnd/Class.hs 572
-   at (Tyvar _ n k) =  tyvar (hsNameIdent_u (hsIdentString_u (++ foo)) n) k
+   at (Tyvar _ n k r) =  tyvar (hsNameIdent_u (hsIdentString_u (++ foo)) n) k r
hunk ./FrontEnd/Class.hs 688
-  | any null tss = fail $ "ambiguity: " ++ (render $ pprint ps) 
+  | any null tss = fail $ "withDefaults.ambiguity: " ++ (render $ pprint ps) ++ show vs ++ show ps
hunk ./FrontEnd/Class.hs 704
-  | any null tss = fail $ "ambiguity: " ++ (render $ pprint ps) ++  show ps  
+  | any null tss = fail $ "useDefaults.ambiguity: " ++ (render $ pprint ps) ++  show ps  
hunk ./FrontEnd/Class.hs 717
-          vs  = [ v  | (Tyvar v _ _,qs,ts) <- ams ]
+          vs  = [ v  | (v,qs,ts) <- ams ]
hunk ./FrontEnd/DataConsAssump.hs 59
-      = TVar (tyvar n k)
+      = TVar (tyvar n k Nothing)
hunk ./FrontEnd/DataConsAssump.hs 72
-      = TVar (tyvar n k)
+      = TVar (tyvar n k Nothing)
hunk ./FrontEnd/HsPretty.hs 256
-ppHsDecl (HsForeignDecl _ _ s n qt) = text "ForeignDecl" <+> ppHsName n <+> ppHsQualType qt
+ppHsDecl fd@(HsForeignDecl _ _ s n qt) = text "ForeignDecl" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)
hunk ./FrontEnd/KindInfer.hs 525
-aHsTypeToType kt (HsTyVar name) = TVar $ tyvar  name (kindOf name kt)
+aHsTypeToType kt (HsTyVar name) = TVar $ tyvar  name (kindOf name kt) Nothing
hunk ./FrontEnd/KindInfer.hs 555
-   = IsIn className (TVar $ tyvar varName (head $ kindOfClass className kt))
+   = IsIn className (TVar $ tyvar varName (head $ kindOfClass className kt) Nothing)
hunk ./FrontEnd/Representation.hs 25
+    findType,
hunk ./FrontEnd/Representation.hs 29
+    flattenType,
hunk ./FrontEnd/Representation.hs 31
+    FlattenType(..),
hunk ./FrontEnd/Representation.hs 48
+import Control.Monad.Trans
hunk ./FrontEnd/Representation.hs 52
+import Data.IORef
hunk ./FrontEnd/Representation.hs 87
-data Tyvar = Tyvar { tyvarAtom :: {-# UNPACK #-} !Atom, tyvarName ::  !HsName, tyvarKind :: Kind }
-    deriving(Data,Typeable, Show)
-    {-! derive: GhcBinary !-}
+data Tyvar = Tyvar { tyvarAtom :: {-# UNPACK #-} !Atom, tyvarName ::  !HsName, tyvarKind :: Kind, tyvarRef :: Maybe (IORef (Maybe Type)) }
+    deriving(Data,Typeable)
+    {-  derive: GhcBinary -}
hunk ./FrontEnd/Representation.hs 91
+instance Show Tyvar where 
+    showsPrec _ Tyvar { tyvarName = hn, tyvarKind = k, tyvarRef = Just _ } = shows hn . (":-" ++) . shows k 
+    showsPrec _ Tyvar { tyvarName = hn, tyvarKind = k } = shows hn . ("::" ++) . shows k 
+
+findType :: MonadIO m => Type -> m Type 
+findType tv@(TVar Tyvar {tyvarRef = Just r }) = liftIO $ do
+    rt <- readIORef r 
+    case rt of 
+        Nothing -> return tv
+        Just t -> do
+            t' <- findType t
+            writeIORef r (Just t')
+            return t'
+findType tv = return tv
+
+refType (TVar tv@Tyvar {tyvarRef = Nothing}) = do
+    r <- newIORef Nothing
+    return $ TVar tv { tyvarRef = Just r } 
+refType t = return t
+
+unrefType (TVar tv) =  TVar tv { tyvarRef = Nothing }
+unrefType t = t
+
+
+class FlattenType t where
+    flattenType' ::  t -> IO t
+
+flattenType :: (FlattenType t, MonadIO m) => t -> m t 
+flattenType t = liftIO (flattenType' t)
+
+instance FlattenType t => FlattenType [t] where
+   flattenType' xs = mapM flattenType' xs 
+
+instance FlattenType Pred where
+    flattenType' (IsIn c t) = do
+        t' <- flattenType' t
+        return $ IsIn c t'
+
+instance FlattenType t => FlattenType (Qual t) where
+    flattenType' (ps :=> t) = do
+        ps' <- flattenType' ps
+        t' <- flattenType' t
+        return $ ps' :=> t'
+
+instance FlattenType Type where
+    flattenType' tv =  do
+        tv' <- findType tv 
+        --tv' <- refType tv'
+        let ft (TAp x y) = do
+                x' <- flattenType' x
+                y' <- flattenType' y
+                return $ TAp x' y'
+            ft (TArrow x y) = do
+                x' <- flattenType' x
+                y' <- flattenType' y
+                return $ TArrow x' y'
+            ft t = return t
+        ft tv'
+
+instance FlattenType Scheme where
+    flattenType' (Forall ks qt) = flattenType' qt >>= return . Forall ks
+
+instance FlattenType Assump where
+    flattenType' (ks :>: qt) = flattenType' qt >>= return . (:>:) ks
+
+instance FlattenType t => FlattenType (Map.Map x t) where
+    flattenType' mp = sequence [flattenType' y >>= return . (,) x| (x,y) <- Map.toAscList mp] >>= return . Map.fromDistinctAscList
+
+instance Show (IORef a) where
+    showsPrec _ _ = ("<IORef>" ++)
+
hunk ./FrontEnd/Representation.hs 355
-type Subst  = Map.Map Atom Type
+type Subst = Map.Map Tyvar Type
hunk ./FrontEnd/Representation.hs 442
+
+instance Binary Tyvar where
+    put_ bh (Tyvar aa ab ac ad) = do
+            put_ bh aa
+            put_ bh ab
+            put_ bh ac
+            --put_ bh ad
+    get bh = do
+    aa <- get bh
+    ab <- get bh
+    ac <- get bh
+    --ad <- get bh
+    --ad <- newIORef Nothing
+    return (Tyvar aa ab ac Nothing)
hunk ./FrontEnd/TIMain.hs 58
+getSubst = return Map.empty
+
hunk ./FrontEnd/TIMain.hs 458
-   = do psEnvT <- tiDecl env decl
-        unify t (trd3 psEnvT)
-        return (fst3 psEnvT, snd3 psEnvT)
+   = do (ps,env,t') <- tiDecl env decl
+        unify t t'
+        return (ps, env)
hunk ./FrontEnd/TIMain.hs 518
---tiExpl ::  TypeEnv -> Expl -> TI ([Pred], TypeEnv)
-tiExpl env (sc, decl)
- = withContext
-       (locSimple (srcLoc decl) ("in the explicitly typed " ++  (render $ ppHsDecl decl))) $
-    do
+tiExpl ::  TypeEnv -> Expl -> TI (Scheme, [Pred], TypeEnv)
+tiExpl env (sc, HsForeignDecl {}) = do
+    return (sc,[],Map.empty)
+tiExpl env (sc, decl) = withContext
+       (locSimple (srcLoc decl) ("in the explicitly typed " ++  (render $ ppHsDecl decl))) $ do
+       --liftIO $ putStrLn  $ render (ppHsDecl decl)
hunk ./FrontEnd/TIMain.hs 525
-       --(qs :=> t) <- fmap snd $ freshInst sc
+       --(qs :=> t) <- -fmap snd $ freshInst sc
hunk ./FrontEnd/TIMain.hs 527
+       t <- flattenType t
+       qs <- flattenType qs
+       --liftIO $ putStrLn  $ show sc
hunk ./FrontEnd/TIMain.hs 531
+       --liftIO $ putStrLn  $ show ps
+       ps <- flattenType ps
+
+       --qs' <- flattenType qs
+       --ps'' <- flattenType ps
+       fs <- liftM tv (flattenType env)
+       --qs' <- sequence [ flattenType y >>= return . IsIn x | IsIn x y <- qs]
hunk ./FrontEnd/TIMain.hs 542
-           fs      = tv (apply s env)
+       --    fs      = tv (apply s env)
hunk ./FrontEnd/TIMain.hs 546
+       --liftIO $ putStrLn  $ show (gs,ps')
hunk ./FrontEnd/TIMain.hs 548
+       --liftIO $ putStrLn  $ show (ds,rs,nsub)
hunk ./FrontEnd/TIMain.hs 575
+tiImpls ::  TypeEnv -> [Impl] -> TI ([Pred], TypeEnv)
hunk ./FrontEnd/TIMain.hs 578
+      --liftIO $ mapM (putStrLn .  render . ppHsDecl) bs 
hunk ./FrontEnd/TIMain.hs 584
-          newEnv1 = Map.fromList $ zip is scs -- map assumpToPair $ zipWith makeAssump is scs
+          newEnv1 = Map.fromList $ zip is scs
hunk ./FrontEnd/TIMain.hs 590
-      let ps'     = apply s (concat pss)
-          ts'     = apply s ts
-          fs      = tv (apply s env)
-          vss@(_:_)  = map tv ts'
+      ps' <- flattenType $ concat pss
+      ts' <- flattenType ts
+      fs <- liftM tv (flattenType env)
+      --let ps'     = apply s (concat pss)
+      --    ts'     = apply s ts
+      --    fs      = tv (apply s env)
+      let vss@(_:_)  = map tv ts'
hunk ./FrontEnd/TIMain.hs 694
+     ps <- flattenType ps 
hunk ./FrontEnd/TIMain.hs 697
-       Right s' -> return $  apply ( s'@@s)  env1
+       Right s' -> do
+        env1' <- flattenType env1
+        return $  apply  s'  env1'
hunk ./FrontEnd/TIMonad.hs 29
-                getSubst,
hunk ./FrontEnd/TIMonad.hs 46
-import Atom
hunk ./FrontEnd/TIMonad.hs 53
-import Type                  ((@@), Types (..), Instantiate (..), nullSubst, mgu)
-import Utils
+import Type                  ((@@), Instantiate (..), mgu)
+import Utils()
hunk ./FrontEnd/TIMonad.hs 68
-      tcSubst             :: IORef Subst,
+      -- tcSubst             :: IORef Subst,
hunk ./FrontEnd/TIMonad.hs 107
-    sub <- newIORef nullSubst
-    c tcenv {  tcVarnum = vn,  tcSubst = sub } where
+    -- sub <- newIORef nullSubst
+    c tcenv {  tcVarnum = vn } where
hunk ./FrontEnd/TIMonad.hs 115
-        tcSubst = undefined,
+        -- tcSubst = undefined,
hunk ./FrontEnd/TIMonad.hs 137
-getSubst :: TI Subst
-getSubst = TI $ \t -> readIORef (tcSubst t) -- gets subst
+--getSubst :: TI Subst
+--getSubst = TI $ \t -> readIORef (tcSubst t) -- gets subst
hunk ./FrontEnd/TIMonad.hs 156
+
hunk ./FrontEnd/TIMonad.hs 169
-unify t1 t2 = do s <- getSubst
-                 let t1' = apply s t1
-                     t2' = apply s t2
+unify t1 t2 = do 
+    t1' <- findType t1
+    t2' <- findType t2
+    b <- mgu t1' t2' 
+    case b of 
+        Just u -> return () -- extSubst u
+        Nothing -> do
+                  diagnosis <- getErrorContext
+                  typeError (Unification $ "attempted to unify " ++
+                                           pretty t1' ++
+                                           " with " ++
+                                           pretty t2')
+                            diagnosis
+
+{-
+--s <- getSubst            
+--let t1' = apply s t1     
+--    t2' = apply s t2     
+
hunk ./FrontEnd/TIMonad.hs 197
+-}
hunk ./FrontEnd/TIMonad.hs 208
-extSubst s' = TI (\t -> modifyIORef (tcSubst t) (s' @@))
+--extSubst s' = TI (\t -> modifyIORef (tcSubst t) (s' @@))
+extSubst s = sequence_ [ do y' <- findType y ; liftIO $ writeIORef r (Just y') | (Tyvar { tyvarRef = ~(Just r)} ,y) <- Map.toList s] 
hunk ./FrontEnd/TIMonad.hs 214
+                r <- newIORef Nothing
hunk ./FrontEnd/TIMonad.hs 216
-                    v = Tyvar (Atom.fromString $ fromHsName ident) ident k
+                    v = tyvar ident k (Just r)
hunk ./FrontEnd/Type.hs 46
-import HsSyn   (HsName (..))
+import Control.Monad.Error
+import Control.Monad.Trans
hunk ./FrontEnd/Type.hs 50
+
+import HsSyn   (HsName (..))
hunk ./FrontEnd/Type.hs 54
+import Data.IORef
hunk ./FrontEnd/Type.hs 85
-  kind (Tyvar _ _ k) = k
+  kind Tyvar { tyvarKind = k} = k
hunk ./FrontEnd/Type.hs 116
-Tyvar u _ _ +-> t     = Map.singleton u t
+u +-> t     = Map.singleton u t
hunk ./FrontEnd/Type.hs 119
-  apply s x@(TVar Tyvar { tyvarAtom = var })
+  apply s x@(TVar var)
hunk ./FrontEnd/Type.hs 158
-mgu     :: Monad m => Type -> Type -> m Subst
+mgu     :: MonadIO m => Type -> Type -> m (Maybe Subst)
hunk ./FrontEnd/Type.hs 161
-mgu (TAp l r) (TAp l' r')
-   = do s1 <- mgu l l'
-        s2 <- mgu (apply s1 r) (apply s1 r')
+mgu x y = do
+    r <- runErrorT (mgu'' x y)
+    case r of 
+        Right x -> return (Just x)
+        Left (_::String) -> return Nothing
+    
+
+mgu'' x y = do
+    x' <- findType x
+    y' <- findType y
+    mgu' x' y'
+
+mgu' (TAp l r) (TAp l' r')
+   = do s1 <- mgu'' l l'
+        --s2 <- mgu'' (apply s1 r) (apply s1 r')
+        s2 <- mgu'' r r'
hunk ./FrontEnd/Type.hs 179
-mgu (TArrow l r) (TArrow l' r')
-   = do s1 <- mgu l l'
-        s2 <- mgu (apply s1 r) (apply s1 r')
+mgu' (TArrow l r) (TArrow l' r')
+   = do s1 <- mgu'' l l'
+        --s2 <- mgu'' (apply s1 r) (apply s1 r')
+        s2 <- mgu'' r r'
hunk ./FrontEnd/Type.hs 185
-mgu (TVar u) t        = varBind u t
-mgu t (TVar u)        = varBind u t
-mgu (TCon tc1) (TCon tc2)
+mgu' t@(TVar Tyvar { tyvarRef = Nothing }) (TVar u@Tyvar { tyvarRef = Just _ } )  = varBind' u t
+mgu' (TVar u) t        = varBind' u t
+mgu' t (TVar u)        = varBind' u t
+mgu' (TCon tc1) (TCon tc2)
hunk ./FrontEnd/Type.hs 192
-mgu t1 t2  = fail "mgu: types do not unify"
+mgu' t1 t2  = fail "mgu: types do not unify"
hunk ./FrontEnd/Type.hs 194
+varBind' u t | t == TVar u      = return nullSubst
+            | u `elem` tv t    = fail "varBind: occurs check fails"
+            | kind u == kind t, Just r <- tyvarRef u = do
+                Nothing <- liftIO $ readIORef r
+                liftIO $ writeIORef r (Just t)
+                return (u +-> t)
+            | otherwise        = fail "varBind: kinds do not match"
+
+
hunk ./FrontEnd/Type.hs 210
-match (TAp l r) (TAp l' r')
+match x y = do
+    --x' <- findType x
+    --y' <- findType y
+    match' x y
+
+match' (TAp l r) (TAp l' r')
hunk ./FrontEnd/Type.hs 220
-match (TArrow l r) (TArrow l' r')
+match' (TArrow l r) (TArrow l' r')
hunk ./FrontEnd/Type.hs 225
-match (TVar u) t
+match' (TVar u) t
hunk ./FrontEnd/Type.hs 228
-match (TCon tc1) (TCon tc2)
+match' (TCon tc1) (TCon tc2)
hunk ./FrontEnd/Type.hs 231
-match t1 t2           = fail $ "match: " ++ show (t1,t2)
+match' t1 t2           = fail $ "match: " ++ show (t1,t2)
hunk ./FrontEnd/Type.hs 245
-       s   = Map.fromList $ map (\(a@(Tyvar x _ _),b) -> (x,b a)) $ zip vs' (map TGen [0..])
+       s   = Map.fromList $ map (\(a,b) -> (a,b a)) $ zip vs' (map TGen [0..])
hunk ./FrontEnd/TypeUtils.hs 55
-   = IsIn className (TVar $ tyvar varName (kindOf className kt))
+   = IsIn className (TVar $ tyvar varName (kindOf className kt) Nothing)