[collect deriving declarations before passing them to derivation code
John Meacham <john@repetae.net>**20120122123601
 Ignore-this: e599fe1d0472ad0d25855b8d177da6e
] hunk ./configure.ac 1
-AC_INIT([jhc],[0.7.8])
+AC_INIT([jhc],[0.8.0])
hunk ./src/DataConstructors.hs 14
+    collectDeriving,
hunk ./src/DataConstructors.hs 65
+import FrontEnd.SrcLoc
hunk ./src/DataConstructors.hs 142
-    conDeriving  :: [Name],       -- classes this type derives
hunk ./src/DataConstructors.hs 187
-                conDeriving = [],
hunk ./src/DataConstructors.hs 420
-deriveClasses :: IdMap Comb -> DataTable -> [(TVr,E)]
-deriveClasses cmap (DataTable mp) = concatMap f (Map.elems mp) where
-    f c | TypeConstructor == nameType (conName c), Just is <- conVirtual c = concatMap (g is c) (conDeriving c)
+deriveClasses :: IdMap Comb -> DataTable -> [(SrcLoc,Name,Name)] -> [(TVr,E)]
+deriveClasses cmap dt@(DataTable mp) ctd = concatMap f ctd where
+    f (_,cd,t) | Just c <- getConstructor t dt, TypeConstructor == nameType (conName c), Just is <- conVirtual c = g is c cd
hunk ./src/DataConstructors.hs 516
+collectDeriving :: [HsDecl] -> [(SrcLoc,Name,Name)]
+collectDeriving ds = concatMap f ds where
+    f decl@HsNewTypeDecl {} = g decl
+    f decl@HsDataDecl {} = g decl
+    f decl@HsDeclDeriving {} = h decl
+    f _ = []
+    g decl = [(hsDeclSrcLoc decl, toName ClassName c,
+        toName TypeConstructor (hsDeclName decl)) | c <- hsDeclDerives decl ]
+    h decl@(hsDeclClassHead -> ch) | [(ltc -> Just t)] <- hsClassHeadArgs ch = [(hsDeclSrcLoc decl,toName ClassName (hsClassHead ch), t)] where
+            ltc (HsTyApp t1 _) = ltc t1
+            ltc (HsTyCon n) = Just (toName TypeConstructor n)
+            ltc x = Nothing
+    h _ = []
+
hunk ./src/DataConstructors.hs 647
-            conDeriving = [ toName ClassName n | n <- hsDeclDerives decl],
hunk ./src/E/Main.hs 104
-    let dataTable = toDataTable (getConstructorKinds (hoKinds $ hoTcInfo ho')) (tiAllAssumptions tiData) originalDecls (hoDataTable $ hoBuild ho)
-        classInstances = deriveClasses (choCombinators cho) dataTable
+    let derives = (collectDeriving originalDecls)
+    mapM_ print derives
+    let dataTable = toDataTable (getConstructorKinds (hoKinds $ hoTcInfo ho'))
+            (tiAllAssumptions tiData) originalDecls (hoDataTable $ hoBuild ho)
+        classInstances = deriveClasses (choCombinators cho) fullDataTable derives
hunk ./src/FrontEnd/Class.hs 64
-    pprint Inst { instHead = h, instAssocs = [] } = pprint h
-    pprint Inst { instHead = h, instAssocs = as } = pprint h <+> text "where" <$> vcat [ text "    type" <+> pprint n <+> text "_" <+> hsep (map pprint ts) <+> text "=" <+> pprint sigma  | (n,_,ts,sigma) <- as]
+    pprint Inst { instHead = h, instAssocs = [], instDerived = d } = (if d then text "*" else text " ") <> pprint h
+    pprint Inst { instHead = h, instAssocs = as, instDerived = d } = (if d then text "*" else text " ") <> pprint h <+> text "where" <$> vcat [ text "    type" <+> pprint n <+> text "_" <+> hsep (map pprint ts) <+> text "=" <+> pprint sigma  | (n,_,ts,sigma) <- as]
hunk ./src/FrontEnd/Utils.hs 27
-            leftMostTyCon (HsTyTuple ts) = error "lehtMostTyCon applied to tuple" -- toTuple (length ts)
+            leftMostTyCon (HsTyTuple ts) = error "leftMostTyCon applied to tuple" -- toTuple (length ts)
hunk ./src/FrontEnd/Utils.hs 54
-
-
hunk ./src/Ho/Build.hs 721
-                dirs = [ "-i" ++ (FP.takeDirectory fp FP.</> x) | x <- mfield "hs-source-dirs" ]
-                    ++ [ "-I" ++ (FP.takeDirectory fp FP.</> x) | x <- mfield "include-dirs" ]
+                dirs = [ "-i" ++ dd x | x <- mfield "hs-source-dirs" ]
+                    ++ [ "-I" ++ dd x | x <- mfield "include-dirs" ]
hunk ./src/Ho/Build.hs 724
+                dd "." = FP.takeDirectory fp
+                dd ('.':'/':x) = dd x
+                dd x = FP.takeDirectory fp FP.</> x