[clean up FrontEnd.Type, add TAssoc to type representation, make type traversal more ticklish in general.
John Meacham <john@repetae.net>**20061018234111] hunk ./FrontEnd/Class.hs 16
+    makeInstanceEnv,
+    InstanceEnv(..),
hunk ./FrontEnd/Class.hs 109
+
+newtype InstanceEnv = InstanceEnv { instanceEnv :: Map.Map (Name,Name) (Tyvar,[Tyvar],Type) }
+
+makeInstanceEnv :: ClassHierarchy -> InstanceEnv
+makeInstanceEnv (ClassHierarchy ch) = InstanceEnv $ Map.fromList (concatMap f (Map.elems ch)) where
+    f cr = concatMap (g cr) (classInsts cr)
+    g cr Inst { instHead = _ :=> IsIn _cname (TAp (TCon ca) (TVar vv)), instAssocs = as } | _cname == className cr = ans where
+        ans = [ ((tyconName tc,tyconName ca),(vv,rs,e)) | (tc,rs,e) <- as]
+
hunk ./FrontEnd/KindInfer.hs 42
-import Type(tTTuple)
hunk ./FrontEnd/Representation.hs 33
+    tassocToAp,
hunk ./FrontEnd/Representation.hs 35
+    tTTuple,
hunk ./FrontEnd/Representation.hs 54
+import Support.CanType
hunk ./FrontEnd/Representation.hs 78
+           | TAssoc   { typeCon :: !Tycon, typeClassArgs :: [Type], typeExtraArgs :: [Type] }
hunk ./FrontEnd/Representation.hs 111
+tassocToAp TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = foldl TAp (TCon con) (cas ++ eas)
hunk ./FrontEnd/Representation.hs 151
-data Tycon = Tycon Name Kind
+data Tycon = Tycon { tyconName :: Name, tyconKind :: Kind }
hunk ./FrontEnd/Representation.hs 323
+    f TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = do
+        let x = atom (pprint con)
+        xs <- mapM f (cas ++ eas)
+        return $ foldl app x xs
hunk ./FrontEnd/Representation.hs 367
+
+instance CanType MetaVar Kind where
+    getType mv = metaKind mv
+
+instance CanType Tycon Kind where
+    getType (Tycon _ k) = k
+
+instance CanType Tyvar Kind where
+    getType = tyvarKind
+
+instance CanType Type Kind where
+  getType (TCon tc) = getType tc
+  getType (TVar u)  = getType u
+  getType typ@(TAp t _) = case (getType t) of
+                     (Kfun _ k) -> k
+                     x -> error $ "Type.getType: kind error in: " ++ (show typ)
+  getType (TArrow _l _r) = Star
+  getType (TForAll _ (_ :=> t)) = getType t
+  getType (TExists _ (_ :=> t)) = getType t
+  getType (TMetaVar mv) = getType mv
+  getType ta@TAssoc {} = getType (tassocToAp ta)
+
+tTTuple ts | length ts < 2 = error "tTTuple"
+tTTuple ts = foldl TAp (toTuple (length ts)) ts
+
hunk ./FrontEnd/Tc/Monad.hs 70
+import FrontEnd.Class
hunk ./FrontEnd/Tc/Monad.hs 95
+    tcInstanceEnv   :: InstanceEnv,
hunk ./FrontEnd/Tc/Monad.hs 174
+        tcInstanceEnv = makeInstanceEnv (tcInfoClassHierarchy tcInfo),
hunk ./FrontEnd/Tc/Type.hs 63
-isTau (TAp a b) = isTau a && isTau b
-isTau (TArrow a b) = isTau a && isTau b
hunk ./FrontEnd/Tc/Type.hs 66
-isTau _ = True
+isTau t = and $ tickleCollect ((:[]) . isTau) t
hunk ./FrontEnd/Tc/Type.hs 70
-isTau' (TAp a b) = isTau a && isTau b
-isTau' (TArrow a b) = isTau a && isTau b
-isTau' _ = True
+isTau' t = and $ tickleCollect ((:[]) . isTau') t
hunk ./FrontEnd/Tc/Type.hs 74
-isBoxy (TForAll _ (_ :=> t)) = isBoxy t
-isBoxy (TAp a b) = isBoxy a || isBoxy b
-isBoxy (TArrow a b) = isBoxy a || isBoxy b
-isBoxy _ = False
+isBoxy t = or $ tickleCollect ((:[]) . isBoxy) t
+
hunk ./FrontEnd/Tc/Type.hs 147
+            ft t = tickleM (unVar' opt . (id :: Type -> Type)) t
hunk ./FrontEnd/Tc/Type.hs 149
-            ft t | ~(Just tv) <- extractTyVar t  = return (TVar tv)
+            --ft t | ~(Just tv) <- extractTyVar t  = return (TVar tv)
+            --ft t | ~(Just tv) <- extractTyVar t  = return (TVar tv)
hunk ./FrontEnd/Tc/Type.hs 191
-freeMetaVars (TVar u)      = []
-freeMetaVars (TAp l r)     = freeMetaVars l `union` freeMetaVars r
-freeMetaVars (TArrow l r)  = freeMetaVars l `union` freeMetaVars r
-freeMetaVars TCon {}       = []
hunk ./FrontEnd/Tc/Type.hs 192
-freeMetaVars (TForAll vs qt) = freeVars qt
-freeMetaVars (TExists vs qt) = freeVars qt
+freeMetaVars t = foldr union [] $ tickleCollect ((:[]) . freeMetaVars) t
+--freeMetaVars (TVar u)      = []
+--freeMetaVars (TAp l r)     = freeMetaVars l `union` freeMetaVars r
+--freeMetaVars (TArrow l r)  = freeMetaVars l `union` freeMetaVars r
+--freeMetaVars TCon {}       = []
+--freeMetaVars (TMetaVar mv) = [mv]
+--freeMetaVars (TForAll vs qt) = freeVars qt
+--freeMetaVars (TExists vs qt) = freeVars qt
hunk ./FrontEnd/Tc/Type.hs 203
-    freeVars (TAp l r)     = freeVars l `union` freeVars r
-    freeVars (TArrow l r)  = freeVars l `union` freeVars r
-    freeVars TCon {}       = []
-    freeVars TMetaVar {}   = []
hunk ./FrontEnd/Tc/Type.hs 205
+    freeVars t = foldr union [] $ tickleCollect ((:[]) . (freeVars :: Type -> [Tyvar])) t
+--    freeVars (TAp l r)     = freeVars l `union` freeVars r
+--    freeVars (TArrow l r)  = freeVars l `union` freeVars r
+--    freeVars TCon {}       = []
+--    freeVars TMetaVar {}   = []
hunk ./FrontEnd/Tc/Type.hs 226
+instance Tickleable Type Type where
+    tickleM f (TAp l r) = return TAp `ap` f l `ap` f r
+    tickleM f (TArrow l r) = return TArrow `ap` f l `ap` f r
+    tickleM f (TAssoc c cas eas) = return (TAssoc c) `ap` mapM f cas `ap` mapM f eas
+    tickleM f (TForAll ta (ps :=> t)) = return (TForAll ta . (ps :=>)) `ap` f t
+    tickleM f (TExists ta (ps :=> t)) = return (TExists ta . (ps :=>)) `ap` f t
+    tickleM _ t = return t
+
hunk ./FrontEnd/Tc/Type.hs 253
-        ft t | ~(Just tv) <- extractTyVar t  = return (TVar tv)
+        ft t = tickleM ft' t
+        --ft t | ~(Just tv) <- extractTyVar t  = return (TVar tv)
hunk ./FrontEnd/Type.hs 27
-    Types (..),
-    match,
-    Subst,
-    tTTuple
+    Types (..)
hunk ./FrontEnd/Type.hs 51
-instance CanType MetaVar Kind where
-    getType mv = metaKind mv
-
-instance CanType Tycon Kind where
-    getType (Tycon _ k) = k
-
-instance CanType Tyvar Kind where
-    getType = tyvarKind
-
-instance CanType Type Kind where
-  getType (TCon tc) = getType tc
-  getType (TVar u)  = getType u
-  getType typ@(TAp t _) = case (getType t) of
-                     (Kfun _ k) -> k
-                     x -> error $ "Type.getType: kind error in: " ++ (show typ)
-  getType (TArrow _l _r) = Star
-  getType (TForAll _ (_ :=> t)) = getType t
-  getType (TExists _ (_ :=> t)) = getType t
-  getType (TMetaVar mv) = getType mv
hunk ./FrontEnd/Type.hs 80
+  apply s (TAssoc c cas eas)  = TAssoc c (map (apply s) cas) (map (apply s) cas)
hunk ./FrontEnd/Type.hs 86
+  tv (TAssoc _ cas eas) = tv cas `union` tv eas
hunk ./FrontEnd/Type.hs 134
-tTTuple ts | length ts < 2 = error "tTTuple"
-tTTuple ts = foldl TAp (toTuple (length ts)) ts