[clean up code, handle equality constraints in more places in the typechecker
John Meacham <john@repetae.net>**20061018044313] hunk ./FrontEnd/Class.hs 65
+import Util.SetLike
hunk ./FrontEnd/Class.hs 75
-import Type
+import Type as T
hunk ./FrontEnd/Class.hs 147
-showPred :: Pred -> String
-showPred (IsIn c t) = show c ++ " " ++ (pretty t)
hunk ./FrontEnd/Class.hs 218
-{-
-   = newHierarchy
-   where
-   newHierarchy
-      -- check to make sure the class exists
-      -- = case lookupFM ch className of
-      = case lookupEnv className ch of
-           Nothing
-              -> error $ "addInstanceToHierarchy: attempt to add instance decl: " ++ showInst inst ++
-                         ", to non-existent class: " ++ show className
-           Just _ -> addToCombFM nodeCombiner className newElement ch
-   newElement = ([], [inst], [])
-   nodeCombiner :: ([HsName], [Inst], [Assump]) -> ([HsName], [Inst], [Assump]) -> ([HsName], [Inst], [Assump])
-   nodeCombiner (_, [newInst], _) (supers, oldInsts, oldMethodSigs) = (supers, newInst:oldInsts, oldMethodSigs)
-
-
-from section 4.3.2 of the Haskell 98 report
-
-instance decls look like:
-   instance cx' => C (T u1 ... uk) where { d }
-
-where u_i are simple variables and are distinct
-
-XXX
-currently hsInstDeclToInst does not check whether the context of
-an instance declaration is legal, for example it allows:
-
-instance (Eq a, Functor a) => Eq (Tree a) where ...
- the kind of Functor, and Eq are different (the Functor is wrong here)
-
--}
hunk ./FrontEnd/Class.hs 298
-convType tsks
-   = foldl1 TAp (map toType tsks)
+convType tsks = foldl1 TAp (map toType tsks)
hunk ./FrontEnd/Class.hs 307
-flattenLeftTypeApplication t
-   = flatTypeAcc t []
-   where
-   flatTypeAcc (HsTyApp t1 t2) acc
-      = flatTypeAcc t1 (t2:acc)
-   flatTypeAcc nonTypApp acc
-      = nonTypApp:acc
-
-{-
-makeDeriveInstances :: [Pred] -> Type -> [Class] -> [Inst]
-makeDeriveInstances context t [] = []
-makeDeriveInstances context t (c:cs)
-   | c `elem` deriveableClasses
-        = (context :=> IsIn c t) : makeDeriveInstances context t cs
-   | otherwise
-        = error $ "makeDeriveInstances: attempt to make type " ++ pretty t ++
-                  "\nan instance of a non-deriveable class " ++ c
--}
+flattenLeftTypeApplication t = flatTypeAcc t [] where
+   flatTypeAcc (HsTyApp t1 t2) acc = flatTypeAcc t1 (t2:acc)
+   flatTypeAcc nonTypApp acc = nonTypApp:acc
hunk ./FrontEnd/Class.hs 311
--- as defined by section 4.3.3 of the haskell report
-{-
-deriveableClasses :: [Class]
-deriveableClasses = ["Eq", "Ord", "Enum", "Bounded", "Show", "Read"]
--}
-
-{-
-
-   converts leftmost type applications into lists
-
-   (((TC v1) v2) v3) => [TC, v1, v2, v3]
-
--}
-
-
---------------------------------------------------------------------------------
-
--- code for making instance methods into top level decls
--- by adding a (instantiated) type signature from the corresponding class
--- decl
---   className
---      = case qualType of
---           HsQualType _cntxt (HsTyApp (HsTyCon className) _argType) -> className
---           HsUnQualType (HsTyApp (HsTyCon className) _argType) -> className
-
--- {-
hunk ./FrontEnd/Class.hs 340
-    cacntxt = [ IsEq (TAp (TCon (Tycon n k)) th) v | ((n,k),[_],~(Just v)) <- createClassAssocs kt methods]
-    (_,(className,[th])) = qtToClassHead kt qualType
+    cacntxt = [ IsEq (TAp (TCon (Tycon n k)) th) (tsubst (uncurry tyvar na) cvar v) | ((n,k),[na],~(Just v)) <- createClassAssocs kt methods]
+    (_,(className,[th@(TAp _ cvar)])) = qtToClassHead kt qualType
hunk ./FrontEnd/Class.hs 346
+    tsubst na vv v = T.apply (msingleton na vv) v
+
hunk ./FrontEnd/Tc/Class.hs 49
-freeMetaVarsPreds ps = concat [ freeMetaVars t | IsIn _ t <- ps ]
+freeMetaVarsPreds ps = concatMap freeMetaVarsPred ps
hunk ./FrontEnd/Tc/Class.hs 53
+freeMetaVarsPred (IsEq t1 t2) = freeMetaVars t1 ++ freeMetaVars t2
hunk ./FrontEnd/Tc/Monad.hs 65
+import Support.Tickle
hunk ./FrontEnd/Tc/Monad.hs 275
-  inst mm ts (IsIn c t) = IsIn c (inst mm ts t)
+  inst mm ts is = tickle (inst mm ts :: Type -> Type) is -- (IsIn c t) = IsIn c (inst mm ts t)
hunk ./FrontEnd/Tc/Monad.hs 381
-        ps' <- sequence [ ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
+        ps' <- sequence (map (tickleM ft') ps) -- [ ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
hunk ./FrontEnd/Tc/Monad.hs 385
-        ps' <- sequence [ ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
+        ps' <- sequence (map (tickleM ft') ps) -- [ ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
+        --ps' <- sequence [ ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
hunk ./FrontEnd/Tc/Type.hs 23
+import Control.Monad.Identity
hunk ./FrontEnd/Tc/Type.hs 36
+import Support.Tickle
hunk ./FrontEnd/Tc/Type.hs 130
+    unVar' opt (IsEq t1 t2) = liftM2 IsEq (unVar' opt t1) (unVar' opt t2)
hunk ./FrontEnd/Tc/Type.hs 220
+    freeVars (IsEq t1 t2)  = freeVars (t1,t2)
+
+
+instance Tickleable Type Pred where
+    tickleM f (IsIn c t) = liftM (IsIn c) (f t)
+    tickleM f (IsEq t1 t2) = return IsEq `ap` f t1 `ap` f t2
+
hunk ./FrontEnd/Tc/Type.hs 235
-            ps' <- sequence [ ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
+            ps' <- sequence (map (tickleM ft') ps) --[  ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
hunk ./FrontEnd/Tc/Type.hs 239
-            ps' <- sequence [ ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
+            ps' <- sequence (map (tickleM ft') ps) --[  ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
+            --ps' <- sequence [ ft' t >>= return . IsIn c | ~(IsIn c t) <- ps ]
hunk ./FrontEnd/Type.hs 80
+  apply s (IsEq t1 t2) = IsEq (apply s t1) (apply s t2)
hunk ./FrontEnd/Type.hs 82
+  tv (IsEq t1 t2)      = tv t1 ++ tv t2