[make lifted class instances have equality constraints
John Meacham <john@repetae.net>**20061018034425] hunk ./FrontEnd/Class.hs 402
+qtToClassHead :: KindEnv -> HsQualType -> ([Pred],(Name,[Type]))
+qtToClassHead kt (HsQualType cntx (HsTyApp (HsTyCon className) ty)) = (map (hsAsstToPred kt) cntx,(toName ClassName className,[runIdentity $ hsTypeToType kt ty]))
+
+createClassAssocs kt decls = [ (ct TypeConstructor n,map (ct TypeVal) as,ctype t)| HsTypeDecl { hsDeclName = n, hsDeclArgs = as, hsDeclType = t } <- decls ] where
+    ct nameType n = let nn = toName nameType n in (nn,kindOf nn kt)
+    ctype HsTyAssoc = Nothing
+    ctype t = Just $ runIdentity $ hsTypeToType kt t
+
hunk ./FrontEnd/Class.hs 412
-   = unzip $ map (methodToTopDecls kt methodSigs qualType) $ methodGroups where
-   HsQualType _ (HsTyApp (HsTyCon className) _) = qualType
-   methodGroups = groupEquations methods
-   methodSigs = case Map.lookup (toName ClassName className) classHierarchy  of
-           Nothing -> error $ "instanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"
-           Just sigs -> classAssumps sigs
+    = unzip $ map (methodToTopDecls kt cacntxt crecord methodSigs qualType) $ methodGroups where
+    methodGroups = groupEquations methods
+    cacntxt = [ IsEq (TAp (TCon (Tycon n k)) th) v | ((n,k),[_],~(Just v)) <- createClassAssocs kt methods]
+    (_,(className,[th])) = qtToClassHead kt qualType
+    crecord = case Map.lookup className classHierarchy  of
+        Nothing -> error $ "instanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"
+        Just crecord -> crecord
+    methodSigs = classAssumps crecord
hunk ./FrontEnd/Class.hs 452
-    instantiatedSig = newMethodSig' kt methodName cntxt sigFromClass argType
+    instantiatedSig = newMethodSig' kt methodName (map (hsAsstToPred kt) cntxt) sigFromClass argType
hunk ./FrontEnd/Class.hs 454
-methodToTopDecls :: KindEnv -> [Assump] -> HsQualType -> (Name, HsDecl) -> (HsDecl,Assump)
+methodToTopDecls :: KindEnv -> [Pred] -> ClassRecord -> [Assump] -> HsQualType -> (Name, HsDecl) -> (HsDecl,Assump)
hunk ./FrontEnd/Class.hs 456
-methodToTopDecls kt methodSigs (HsQualType cntxt classApp) (methodName, methodDecls)
+methodToTopDecls kt preds crecord methodSigs qt@(HsQualType cntxt classApp) (methodName, methodDecls)
hunk ./FrontEnd/Class.hs 459
+--    (cntxt,(className,[argType])) = qtToClassHead qt
hunk ./FrontEnd/Class.hs 464
-    --instantiatedSig = newMethodSig' (kiHsQualTypePredPred kt qt) cntxt sigFromClass argType
-    instantiatedSig = newMethodSig' kt methodName cntxt sigFromClass argType
-     --  = newMethodSig cntxt newMethodName sigFromClass argType
+    instantiatedSig = newMethodSig' kt methodName (preds ++ map (hsAsstToPred kt) cntxt) sigFromClass argType
hunk ./FrontEnd/Class.hs 493
-newMethodSig' :: KindEnv -> Name -> HsContext -> Sigma -> HsType -> Sigma
+newMethodSig' :: KindEnv -> Name -> [Pred] -> Sigma -> HsType -> Sigma
hunk ./FrontEnd/Class.hs 512
-   qt = (map (hsAsstToPred kt) newCntxt ++ restContext) :=> (everywhere (mkT ct) t)
+   qt = (newCntxt ++ restContext) :=> (everywhere (mkT ct) t)
hunk ./FrontEnd/Representation.hs 283
+    fp (IsEq t1 t2) = do
+        t1' <- f t1
+        t2' <- f t2
+        return (atom (parens $ unparse t1' <+> text "=" <+> unparse t2'))
hunk ./FrontEnd/Representation.hs 343
+    pprint (IsEq t1 t2) = parens $ prettyPrintType t1 <+> text "=" <+> prettyPrintType t2