[add support for classes in generalization step.
John Meacham <john@repetae.net>**20060213065324] {
hunk ./FrontEnd/Tc/Main.hs 8
-import Class(ClassHierarchy, entails, split, topDefaults, splitReduce)
+import Class(ClassHierarchy, entails, split, topDefaults, splitReduce,simplify)
hunk ./FrontEnd/Tc/Main.hs 382
-    rs <- localEnv (Map.fromList [  (getDeclName d,s) | d <- bs | s <- ss]) $ sequence [ tcDecl d s | d <- bs | s <- ss ]
+    (rs,ps) <- censor (const mempty) $ listen $ localEnv (Map.fromList [  (getDeclName d,s) | d <- bs | s <- ss]) $ sequence [ tcDecl d s | d <- bs | s <- ss ]
+    ps <- mapM flattenType ps
+    ch <- getClassHierarchy
+    ps <- return $ Class.simplify ch ps
hunk ./FrontEnd/Tc/Main.hs 390
-            s <- generalize s
+            s <- generalize ps s
hunk ./FrontEnd/Tc/Main.hs 738
-tiProgram bgs es = f bgs [] mempty where
+tiProgram bgs es = ans where
+    ans = do
+        (r,ps) <- listen $ f bgs [] mempty
+        ps <- flattenType ps
+        ch <- getClassHierarchy
+        ps <- return $ Class.simplify ch ps
+        liftIO $ mapM_ (putStrLn.show) ps
+        return r
hunk ./FrontEnd/Tc/Module.hs 223
-        ce <- getCollectedEnv
-        liftIO $ mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |  (n,s) <- Map.toList ce]
-        return (Map.map typeToScheme ce)
+        getCollectedEnv
+        --liftIO $ mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |  (n,s) <- Map.toList ce]
+        --return (Map.map typeToScheme ce)
hunk ./FrontEnd/Tc/Module.hs 227
-    when (dump FD.Types) $
-         do {putStrLn " ---- the types of identifiers ---- ";
-             putStrLn $ PPrint.render $ pprintEnv (if verbose2 then localVarEnv else trimEnv localVarEnv) }
+    when (dump FD.Types) $ do
+        putStrLn " ---- the types of identifiers ---- "
+        mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |  (n,s) <- Map.toList (if verbose2 then localVarEnv else trimEnv localVarEnv)]
+
+    localVarEnv <- return $ Map.map typeToScheme localVarEnv
hunk ./FrontEnd/Tc/Monad.hs 49
-import Class(ClassHierarchy)
+import Class(ClassHierarchy,simplify)
hunk ./FrontEnd/Tc/Monad.hs 72
-    tcCurrentScope      :: Set.Set Atom,
+    tcCurrentScope      :: Set.Set MetaVar,
hunk ./FrontEnd/Tc/Monad.hs 127
+        tcCurrentScope = mempty,
hunk ./FrontEnd/Tc/Monad.hs 293
-generalize :: Rho -> Tc Sigma
-generalize r = do
+generalize :: [Pred] -> Rho -> Tc Sigma
+generalize ps r = do
+    ch <- getClassHierarchy
hunk ./FrontEnd/Tc/Monad.hs 299
-    quantify ([ v  | v <- freeMetaVars r, not $ v `Set.member` fmvenv ]) [] r
+    let mvs =  [ v  | v <- freeMetaVars r, not $ v `Set.member` fmvenv ]
+    let (rp,nps) = partition (\ (IsIn c t) -> any (`elem` mvs) (freeMetaVars t)) ps
+    addPreds nps
+    quantify mvs rp r
hunk ./FrontEnd/Tc/Monad.hs 317
-    ret <- flattenType (ps :=> r)
-    return $ TForAll nvs ret
-    --return $ TForAll nvs (ps' :=> rr)
-    --let mm =  Map.fromList  [ (metaUniq mv,(TVar v)) | v <- nvs |  mv <- vs ]
-    --    rr = inst mm mempty r
-    --    ps' = inst mm mempty ps
-    --r <- flattenType (ps :=> r)
-    --return $ TForAll nvs (ps' :=> rr)
+    (ps :=> r) <- flattenType (ps :=> r)
+    ch <- getClassHierarchy
+    return $ TForAll nvs (Class.simplify ch ps :=> r)
hunk ./Interactive.hs 237
-    TForAll vs ([] :=> t) <- generalize vv -- quantify (tv vv) qt
+    TForAll vs (ps :=> t) <- generalize ps vv -- quantify (tv vv) qt
}
