[fix bug where class rules were not generated for internally generated instances in some cases
John Meacham <john@repetae.net>**20120130093500
 Ignore-this: ef97c8efb2679ab4c63d5be41a6ef5f8
] hunk ./src/E/FromHs.hs 189
-    cClass classRecord =  concat [ method classRecord n mve | (n,TForAll _ (_ :=> t)) <- classAssumps classRecord, mve <- findName n ]
-
+    cClass classRecord = concat [ method classRecord n mve |
+        (n,TForAll _ (_ :=> t)) <- classAssumps classRecord, mve <- findName n ]
hunk ./src/E/FromHs.hs 194
-
-        as = [ rule  t | Inst { instHead = _ :=> IsIn _ t }  <- snub (classInsts classRecord) ]
-        rule t = makeRule ("Rule.{" ++ show name ++ "}") (toModule (show name),0) RuleSpecialization ruleFvs methodVar (vp:map EVar args) (removeNewtypes dataTable body)  where
+        as = [ rule t | Inst { instHead = _ :=> IsIn _ t } <- snub (classInsts classRecord) ]
+        rule t = makeRule ("Rule.{" ++ show name ++ "}") (toModule (show name),0)
+                RuleSpecialization ruleFvs methodVar (vp:map EVar args) (removeNewtypes dataTable body) where
hunk ./src/E/Main.hs 32
+import FrontEnd.Class(augmentClassHierarchy)
hunk ./src/E/Main.hs 127
-    let ds = [ (v,e) | (v,e) <- classInstances ] ++
-            [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ]
+    let ds = classInstances ++ [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ]
hunk ./src/E/Main.hs 129
-    instanceRules <- createInstanceRules fullDataTable (hoClassHierarchy $ hoTcInfo ho')  (ds `mappend` hoEs (hoBuild ho))
+    let augmentedClassHierarchy = hoClassHierarchy (hoTcInfo ho) `augmentClassHierarchy` hoClassHierarchy (hoTcInfo ho')
+    instanceRules <- createInstanceRules fullDataTable augmentedClassHierarchy (ds `mappend` hoEs (hoBuild ho))
hunk ./src/E/Main.hs 164
-    let entryPoints = fromList . execWriter $ programMapDs_ (\ (t,_) -> when 
+    let entryPoints = fromList . execWriter $ programMapDs_ (\ (t,_) -> when
hunk ./src/E/Main.hs 372
-    when (dodump && (dump FD.Progress || coreSteps)) $ 
+    when (dodump && (dump FD.Progress || coreSteps)) $
hunk ./src/E/Main.hs 427
-        flip mapM_ (programDs prog) $ \ (t,e) -> do
+        flip mapM_ (sortUnder (show . fst) (programDs prog)) $ \ (t,e) -> do
hunk ./src/E/Main.hs 430
-        when (not (null ts')) $ putStrLn $ (pprint t) ++ " \\" ++ concat [ "(" ++ show  (Info.fetch (tvrInfo t) :: Typ) ++ ")" | t <- ts' ]
+        when (not (null ts')) $ putStrLn $ (pprint t) ++ " \\" ++
+            concat [ "(" ++ show  (Info.fetch (tvrInfo t) :: Typ) ++ ")" | t <- ts' ]
hunk ./src/E/Main.hs 442
-    prog <- evaluate $ progCombinators_s ([ p | p <- progCombinators prog, combHead p `notElem` map combHead cmethods] ++ cmethods) prog
-    prog <- annotateProgram mempty (\_ nfo -> return $ unsetProperty prop_INSTANCE nfo) letann (\_ nfo -> return nfo) prog
+    prog <- evaluate $ progCombinators_s ([ p | p <- progCombinators prog,
+        combHead p `notElem` map combHead cmethods] ++ cmethods) prog
+    prog <- annotateProgram mempty (\_ nfo -> return $ unsetProperty prop_INSTANCE nfo)
+        letann (\_ nfo -> return nfo) prog
hunk ./src/E/Main.hs 450
-        prog <- transformProgram transformParms { transformCategory = "LambdaLift", transformDumpProgress = dump FD.Progress, transformOperation = lambdaLift } prog
+        prog <- transformProgram transformParms {
+            transformCategory = "LambdaLift",
+            transformDumpProgress = dump FD.Progress,
+            transformOperation = lambdaLift } prog
hunk ./src/E/Main.hs 459
-    prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterMethod", transformDumpProgress = verbose } prog
+    prog <- transformProgram transTypeAnalyze {
+        transformPass = "Main-AfterMethod",
+        transformDumpProgress = verbose } prog
hunk ./src/E/Main.hs 465
-    prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterSimp", transformDumpProgress = verbose } prog
+    prog <- transformProgram transTypeAnalyze {
+        transformPass = "Main-AfterSimp", transformDumpProgress = verbose } prog
hunk ./src/E/Main.hs 470
-    prog <- return $ runIdentity $ annotateProgram mempty (\_ nfo -> return $ modifyProperties (flip (foldr S.delete) [prop_HASRULE,prop_WORKER]) nfo) letann (\_ -> return) prog
+    prog <- return $ runIdentity $ annotateProgram mempty (\_ nfo -> return $
+        modifyProperties (flip (foldr S.delete) [prop_HASRULE,prop_WORKER]) nfo)
+        letann (\_ -> return) prog
hunk ./src/E/Main.hs 475
-    prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True } "SuperSimplify no rules" verbose prog
+    prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True }
+        "SuperSimplify no rules" verbose prog
hunk ./src/E/Main.hs 487
-    prog <- transformProgram transformParms { transformCategory = "BoxifyProgram", transformDumpProgress = dump FD.Progress, transformOperation = boxifyProgram } prog
+    prog <- transformProgram transformParms {
+        transformCategory = "BoxifyProgram",
+        transformDumpProgress = dump FD.Progress,
+        transformOperation = boxifyProgram } prog
hunk ./src/E/Main.hs 495
-    prog <- transformProgram transformParms { transformCategory = "Boxy WorkWrap", transformDumpProgress = dump FD.Progress, transformOperation = evaluate . workWrapProgram } prog
-    prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True } "SuperSimplify after Boxy WorkWrap" verbose prog
+    prog <- transformProgram transformParms {
+        transformCategory = "Boxy WorkWrap",
+        transformDumpProgress = dump FD.Progress,
+        transformOperation = evaluate . workWrapProgram } prog
+    prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True }
+        "SuperSimplify after Boxy WorkWrap" verbose prog
hunk ./src/E/Main.hs 504
-    prog <- transformProgram transformParms { transformCategory = "LambdaLift", transformDumpProgress = dump FD.Progress, transformOperation = lambdaLift } prog
+    prog <- transformProgram transformParms {
+        transformCategory = "LambdaLift",
+        transformDumpProgress = dump FD.Progress,
+        transformOperation = lambdaLift } prog
hunk ./src/E/Main.hs 529
-    prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_postLift = True, SS.so_finalPhase = True } "PostLiftSimplify" verbose prog
+    prog <- simplifyProgram SS.emptySimplifyOpts {
+        SS.so_postLift = True, SS.so_finalPhase = True } "PostLiftSimplify" verbose prog
hunk ./src/E/PrimDecode.hs 55
-    [ "seq" ==> star +> starHash +> starHash
-    , "dependingOn" ==> star +> starHash +> star
-    , "newWorld__" ==> star +> state
-    , "unsafeCoerce" ==> star +> star
+    [ "seq"            ==> star +> starHash +> starHash
+    , "dependingOn"    ==> star +> starHash +> star
+    , "newWorld__"     ==> star +> state
+    , "unsafeCoerce"   ==> star +> star
hunk ./src/E/PrimDecode.hs 60
-    , "touch_" ==> starHash +> state +> state
-    , "zero" ==> starHash
-    , "one" ==> starHash
-    , "box" ==> hash +> star
-    , "unbox" ==> star +> hash
-    , "constPeekByte" ==> hash +> hash
-    , "exitFailure__" ==> hash +> hash
+    , "touch_"         ==> starHash +> state +> state
+    , "zero"           ==> starHash
+    , "one"            ==> starHash
+    , "box"            ==> hash +> star
+    , "unbox"          ==> star +> hash
+    , "constPeekByte"  ==> hash +> hash
+    , "exitFailure__"  ==> hash +> hash
hunk ./src/FrontEnd/Class.hs 6
+    augmentClassHierarchy,
hunk ./src/FrontEnd/Class.hs 74
+-- augment heirarchy with just instances with full class definitions
+augmentClassHierarchy :: ClassHierarchy -> ClassHierarchy -> ClassHierarchy
+augmentClassHierarchy (ClassHierarchy full) (ClassHierarchy restricted) = ans where
+    ans = ClassHierarchy (fmap f restricted)
+    f ch = fl { classInsts = classInsts ch } where
+        fl = case Map.lookup (className ch) full of
+            Nothing -> ch
+            Just f -> combineClassRecords ch f
+
+