[check superclass constraints on instance declarations
John Meacham <john@repetae.net>**20120205025815
 Ignore-this: 6c5df51b853ecba4af51fba6cc4f7436
] hunk ./src/FrontEnd/Class.hs 7
+    chToClassHead,
hunk ./src/FrontEnd/Tc/Main.hs 13
+import FrontEnd.Class
hunk ./src/FrontEnd/Tc/Main.hs 614
-tcPragmaDecl spec@HsPragmaSpecialize { hsDeclSrcLoc = sloc, hsDeclName = n, hsDeclType = t } = do
-    withContext (locMsg sloc "in the SPECIALIZE pragma" $ show n) ans where
-    ans = do
+tcMiscDecl d = withContext (locMsg (srcLoc d) "in the declaration" "") $ f d where
+    f spec@HsPragmaSpecialize { hsDeclSrcLoc = sloc, hsDeclName = n, hsDeclType = t } = do
+        withContext (locMsg sloc "in the SPECIALIZE pragma" $ show n) ans where
+        ans = do
+            kt <- getKindEnv
+            t <- hsTypeToType kt t
+            let nn = toName Val n
+            sc <- lookupName nn
+            listenPreds $ sc `subsumes` t
+            addRule RuleSpec { ruleUniq = hsDeclUniq spec, ruleName = nn, ruleType = t, ruleSuper = hsDeclBool spec }
+            return [spec]
+    f i@HsInstDecl {} = tcClassHead (hsDeclClassHead i)
+    f i@HsDeclDeriving {} = tcClassHead (hsDeclClassHead i)
+    f (HsPragmaRules rs) = do
+        rs' <- mapM tcRule rs
+        return [HsPragmaRules rs']
+    f fd@(HsForeignDecl _ _ n qt) = do
hunk ./src/FrontEnd/Tc/Main.hs 632
-        t <- hsTypeToType kt t
-        let nn = toName Val n
-        sc <- lookupName nn
-        listenPreds $ sc `subsumes` t
-        addRule RuleSpec { ruleUniq = hsDeclUniq spec, ruleName = nn, ruleType = t, ruleSuper = hsDeclBool spec }
-        return [spec]
-
-tcPragmaDecl (HsPragmaRules rs) = do
-    rs' <- mapM tcRule rs
-    return [HsPragmaRules rs']
-
--- foreign decls are accumulated by tiExpl
-tcPragmaDecl fd@(HsForeignDecl _ _ n qt) = do
-    kt <- getKindEnv
-    s <- hsQualTypeToSigma kt qt
-    addToCollectedEnv (Map.singleton (toName Val n) s)
-    return []
-
-tcPragmaDecl fd@(HsForeignExport _ e n qt) = do
-    kt <- getKindEnv
-    s <- hsQualTypeToSigma kt qt
-    addToCollectedEnv (Map.singleton (ffiExportName e) s)
-    return []
+        s <- hsQualTypeToSigma kt qt
+        addToCollectedEnv (Map.singleton (toName Val n) s)
+        return []
+    f fd@(HsForeignExport _ e n qt) = do
+        kt <- getKindEnv
+        s <- hsQualTypeToSigma kt qt
+        addToCollectedEnv (Map.singleton (ffiExportName e) s)
+        return []
+    f _ = return []
+    tcClassHead cHead@HsClassHead { .. } = do
+        ch <- getClassHierarchy
+        ke <- getKindEnv
+        let supers = asksClassRecord ch hsClassHead classSupers
+            (ctx,(cn,[a])) = chToClassHead ke cHead
+        assertEntailment ctx [ IsIn s a | s <- supers]
+        return []
hunk ./src/FrontEnd/Tc/Main.hs 649
-tcPragmaDecl _ = return []
hunk ./src/FrontEnd/Tc/Main.hs 790
-        pdecls <- mapM tcPragmaDecl es
+        pdecls <- mapM tcMiscDecl es
hunk ./src/FrontEnd/Tc/Main.hs 816
---tiProgram = undefined
-