[don't create dummy instances for Eq,Ord,Enum, support standalone deriving of some classes, allow mulitple derivations when compatible.
John Meacham <john@repetae.net>**20120123021301
 Ignore-this: c1da13e93ecf08c1ce371af23aa3e937
] hunk ./src/DerivingDrift/Drift.hs 3
-import Char
-import List
+import Data.Char
hunk ./src/DerivingDrift/Drift.hs 64
-derive True d (toName ClassName -> wh) | Just fns <- lookup wh enumDontDerive = inst fns where
-    dummy = "{- This is a dummy instance, it will be rewritten internally -}\n"
-    inst fns = dummy ++ "instance " ++ show wh ++ " " ++ name d ++ " where\n" ++ concat (intersperse "\n" (map f fns))
-    f n = "    " ++ g (show n) ++ " = " ++ g (show n)
-    g (c:cs) | c == '_' || c == '\'' || isAlpha c = c:cs
-    g x = "(" ++ x ++ ")"
+derive True d (toName ClassName -> wh) | Just fns <- lookup wh enumDontDerive = "" where
+--derive True d (toName ClassName -> wh) | Just fns <- lookup wh enumDontDerive = inst fns where
+--    dummy = "{- This is a dummy instance, it will be rewritten internally -}\n"
+--    inst fns = dummy ++ "instance " ++ show wh ++ " " ++ name d ++ " where\n" ++ concat (intersperse "\n" (map f fns))
+--    f n = "    " ++ g (show n) ++ " = " ++ g (show n)
+--    g (c:cs) | c == '_' || c == '\'' || isAlpha c = c:cs
+--    g x = "(" ++ x ++ ")"
hunk ./src/E/FromHs.hs 611
-    cDecl HsNewTypeDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCon = dcon, hsDeclDerives = derives } = return $ makeDerives dname dargs [dcon] (map (toName ClassName) derives)
-    cDecl HsDataDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCons = dcons, hsDeclDerives = derives } = return $ makeDerives dname dargs dcons (map (toName ClassName) derives)
hunk ./src/E/FromHs.hs 613
-    makeDerives dname dargs dcons derives  = concatMap f derives where
-        f n | n == class_Bounded, all (null . hsConDeclArgs) dcons  = []
-        f _ = []
hunk ./src/FrontEnd/Class.hs 15
+    addInstanceToHierarchy,
hunk ./src/FrontEnd/Class.hs 19
+    enumDerivableClasses,
+    noNewtypeDerivable,
hunk ./src/FrontEnd/Class.hs 22
+    emptyInstance,
hunk ./src/FrontEnd/Class.hs 76
-data ClassRecord = ClassRecord      { className :: Class,
-                                      classSrcLoc :: SrcLoc,
-                                      classArgs :: [Tyvar],
-                                      classSupers :: [Class],
-                                      classInsts :: [Inst],
+data ClassRecord = ClassRecord      { className    :: Class,
+                                      classSrcLoc  :: SrcLoc,
+                                      classArgs    :: [Tyvar],
+                                      classSupers  :: [Class],
+                                      classInsts   :: [Inst],
hunk ./src/FrontEnd/Class.hs 82
-                                      classAssocs :: [(Tycon,[Tyvar],Maybe Sigma)]
+                                      classAssocs  :: [(Tycon,[Tyvar],Maybe Sigma)]
hunk ./src/FrontEnd/Class.hs 84
-                 | ClassAliasRecord { className :: Class,
-                                      classSrcLoc :: SrcLoc,
-                                      classArgs :: [Tyvar],
-                                      classSupers :: [Class],
-                                      classInsts :: [Inst],
+                 | ClassAliasRecord { className    :: Class,
+                                      classSrcLoc  :: SrcLoc,
+                                      classArgs    :: [Tyvar],
+                                      classSupers  :: [Class],
+                                      classInsts   :: [Inst],
hunk ./src/FrontEnd/Class.hs 230
+modifyClassRecordM :: Monad m => (ClassRecord -> m ClassRecord) -> Class ->  ClassHierarchy -> m ClassHierarchy
+modifyClassRecordM  f c (ClassHierarchy h) = ans where
+    ans = case Map.lookup c h of
+        Nothing -> g (newClassRecord c)
+        Just r -> g r
+    g r = do
+        cr <- f r
+        return $ ClassHierarchy (Map.insert c cr h)
+
hunk ./src/FrontEnd/Class.hs 243
+addInstanceToHierarchy :: Inst -> ClassHierarchy -> ClassHierarchy
+addInstanceToHierarchy inst@Inst { instHead = cntxt :=> IsIn className _ } ch = runIdentity $ modifyClassRecordM f className ch where
+    f c = do
+        nil <- ensureNotDup (instSrcLoc inst) inst (classInsts c)
+        return $ c { classInsts = nil }
+
hunk ./src/FrontEnd/Class.hs 252
-        = return [emptyInstance { instSrcLoc = sloc, instDerived = False, instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs }]
+        = return [emptyInstance { instSrcLoc = sloc, instDerived = False,
+        instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs }]
hunk ./src/FrontEnd/Class.hs 532
-ensureNotDup :: Monad m => SrcLoc -> Inst -> [Inst] -> m ()
-ensureNotDup sl i is | i `elem` is = failSl sl $ "Duplicate Instance: " ++ show i
-                     | otherwise = return ()
+ensureNotDup :: Monad m => SrcLoc -> Inst -> [Inst] -> m [Inst]
+ensureNotDup sl i is = f i is where
+    f i (i':is') | instHead i == instHead i' = case instDerived i && instDerived i' of
+        True -> return is
+        False -> failSl sl $ "Duplicate Instance: " ++ show i ++ "\nPrevious instance declared at " ++ show (instSrcLoc i')
+    f i (_:is') = f i is'
+    f i [] = return $ i:is
hunk ./src/FrontEnd/Class.hs 587
+
+-- can be automatically derived when
+-- the class is an enumeration
+enumDerivableClasses ::  [Name]
+enumDerivableClasses = [
+    class_Eq,
+    class_Ord,
+    class_Enum
+    ]
+
+-- classes that cannot be derived by the generalized
+-- newtype deriving mechanism.
+noNewtypeDerivable :: [Name]
+noNewtypeDerivable = [
+    class_Show,
+    class_Read
+    ]
hunk ./src/FrontEnd/Tc/Module.hs 6
+import qualified Data.Foldable as T
hunk ./src/FrontEnd/Tc/Module.hs 9
-import qualified Data.Foldable as T
hunk ./src/FrontEnd/Tc/Module.hs 10
-import FrontEnd.DataConsAssump     (dataConsEnv)
-import FrontEnd.DeclsDepends       (getDeclDeps, debugDeclBindGroups)
-import FrontEnd.DependAnalysis     (getBindGroups)
+import DataConstructors
hunk ./src/FrontEnd/Tc/Module.hs 14
+import FrontEnd.DataConsAssump     (dataConsEnv)
+import FrontEnd.DeclsDepends       (getDeclDeps, debugDeclBindGroups)
+import FrontEnd.DependAnalysis     (getBindGroups)
hunk ./src/FrontEnd/Tc/Module.hs 19
+import FrontEnd.HsSyn
hunk ./src/FrontEnd/Tc/Module.hs 26
+import FrontEnd.TypeSigs           (collectSigs, listSigsToSigEnv)
+import FrontEnd.TypeSynonyms
+import FrontEnd.TypeSyns
hunk ./src/FrontEnd/Tc/Module.hs 32
-import FrontEnd.HsSyn
hunk ./src/FrontEnd/Tc/Module.hs 35
-import FrontEnd.TypeSigs           (collectSigs, listSigsToSigEnv)
-import FrontEnd.TypeSynonyms
-import FrontEnd.TypeSyns
---import ClassAliases
hunk ./src/FrontEnd/Tc/Module.hs 43
-
hunk ./src/FrontEnd/Tc/Module.hs 61
-
-
hunk ./src/FrontEnd/Tc/Module.hs 67
-
hunk ./src/FrontEnd/Tc/Module.hs 76
-
hunk ./src/FrontEnd/Tc/Module.hs 92
-
hunk ./src/FrontEnd/Tc/Module.hs 99
+-- Very broad information on a data type.
+-- Flag is whether it is a newtype.
+data DatDesc
+    = DatEmpty
+    | DatEnum [Name]
+    | DatMany Bool [(Name,Int)]
+
+getDataDesc :: Monad m => HsDecl -> m (Name,DatDesc)
+getDataDesc d = g d where
+    g desc = do
+        r <- f d
+        return (hsDeclName desc,r)
+    f HsNewTypeDecl { hsDeclName = n, hsDeclCon = (hsConDeclName -> cn)  } = return $ DatMany True [(cn,1)]
+    f HsDataDecl { hsDeclName = n, hsDeclCons = [] } = return $ DatEmpty
+    f HsDataDecl { hsDeclName = n, hsDeclCons = cs }
+        | all null $ map hsConDeclArgs cs = return $ DatEnum (map hsConDeclName cs)
+    f HsDataDecl { hsDeclName = n, hsDeclCons = cs } = return $ DatMany True [ (hsConDeclName c, (length . hsConDeclArgs) c) | c <- cs]
+    f _ = fail "getDataDesc: not a data declaration"
+
+suitableForDeriving :: [HsDecl] -> (Set.Set Name,Set.Set Name)
+suitableForDeriving ds = f ds Set.empty Set.empty where
+    f [] a b = (a,b)
+    f (HsNewTypeDecl { hsDeclName = n }:ds) a b = f ds (Set.insert n a) b
+    f (HsDataDecl { hsDeclName = n, hsDeclCons = cs@(_:_:_) }:ds) a b
+        | all null $ map hsConDeclArgs cs = f ds a (Set.insert n b)
+    f (_:ds) a b = f ds a b
+
hunk ./src/FrontEnd/Tc/Module.hs 157
-
hunk ./src/FrontEnd/Tc/Module.hs 176
-
hunk ./src/FrontEnd/Tc/Module.hs 178
+    let smallClassHierarchy = foldr addInstanceToHierarchy (makeClassHierarchy importClassHierarchy kindInfo ds) dinsts
+        cHierarchyWithInstances = scatterAliasInstances $ smallClassHierarchy `mappend` importClassHierarchy
+        derivingClauses = collectDeriving ds
+        dataInfo = Map.fromList $ concatMap getDataDesc ds
+        dinsts = concatMap g derivingClauses where
+            g r@(_,c,t) | c `elem` enumDerivableClasses, Just (DatEnum _) <- Map.lookup t dataInfo = [f r]
+            --g r@(_,c,t) | c `notElem` noNewtypeDerivable, Just (DatMany True [_]) <- Map.lookup t dataInfo = [f r]
+            g _ = []
+            f (sl,c,t) = emptyInstance { instSrcLoc = sl, instDerived = True, instHead = [] :=> IsIn c (TCon (Tycon t kindStar)) }
hunk ./src/FrontEnd/Tc/Module.hs 188
-    let smallClassHierarchy = makeClassHierarchy importClassHierarchy kindInfo ds
-    let cHierarchyWithInstances = scatterAliasInstances $ smallClassHierarchy `mappend` importClassHierarchy
hunk ./src/FrontEnd/Tc/Module.hs 206
-
hunk ./src/FrontEnd/Tc/Module.hs 211
-
hunk ./src/FrontEnd/Tc/Module.hs 312
-
hunk ./src/Info/Info.hs 36
-    entryType    :: TypeRep
+    entryType    :: !TypeRep