[Rework the internal class representation to separate instances from class declarations
John Meacham <john@repetae.net>**20120201073400
 Ignore-this: b4bbb5d887a4985864ef9a27eaab606f
] hunk ./src/E/FromHs.hs 194
-        as = [ rule t | Inst { instHead = _ :=> IsIn _ t } <- snub (classInsts classRecord) ]
+        as = [ rule t | Inst { instHead = _ :=> IsIn _ t } <- snub (findClassInsts classHierarchy (className classRecord)) ]
hunk ./src/FrontEnd/Class.hs 1
-{-# LANGUAGE NoMonoLocalBinds #-}
+{-# LANGUAGE NoMonoLocalBinds, NamedFieldPuns #-}
hunk ./src/FrontEnd/Class.hs 5
-    ClassHierarchy,
+    ClassHierarchy(),
hunk ./src/FrontEnd/Class.hs 8
-    isClassRecord,
-    isClassAliasRecord,
hunk ./src/FrontEnd/Class.hs 11
+    findClassInsts,
hunk ./src/FrontEnd/Class.hs 75
-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
-
+augmentClassHierarchy (CH full _) (CH res is) = ans where
+    ans = CH (Map.mapWithKey f is) is
+    f cn _ = r where Just r = Map.lookup cn (Map.union res full)
hunk ./src/FrontEnd/Class.hs 80
--- you can tell the difference by the presence of the classArgs field
+-- you can tellthe difference by the presence of the classArgs field
+
+data ClassType
+    = ClassNormal | ClassTypeFamily | ClassDataFamily | ClassAlias
+        deriving(Eq,Ord)
hunk ./src/FrontEnd/Class.hs 86
-data ClassRecord = ClassRecord      { className    :: Class,
-                                      classSrcLoc  :: SrcLoc,
-                                      classArgs    :: [Tyvar],
-                                      classSupers  :: [Class],
-                                      classInsts   :: [Inst],
-                                      classAssumps :: [(Name,Sigma)], -- ^ method signatures
-                                      classAssocs  :: [(Tycon,[Tyvar],Maybe Sigma)]
-                                    }
-                 | ClassAliasRecord { className    :: Class,
-                                      classSrcLoc  :: SrcLoc,
-                                      classArgs    :: [Tyvar],
-                                      classSupers  :: [Class],
-                                      classInsts   :: [Inst],
-                                      classClasses :: [Class],
-                                      classMethodMap :: Map.Map Name Class
-                                    }
-    deriving Show
-    {-! derive: Binary, is !-}
+-- Bool is true if data declaration instead of type declaration
+data AssociatedType = Assoc Tycon !Bool [Tyvar] Kind
+    deriving(Eq,Show)
+    {-! derive: Binary !-}
+
+data ClassRecord = ClassRecord {
+    className    :: Class, -- ^ can be a TypeConstructor if we are a type or data family
+    classSrcLoc  :: SrcLoc,
+    classArgs    :: [Tyvar],
+    classSupers  :: [Class], -- TODO: should be Pred
+    classAlias   :: Maybe (Qual [Pred]),
+    classAssumps :: [(Name,Sigma)], -- ^ method signatures
+    classAssocs  :: [AssociatedType]
+    } deriving (Show,Eq)
+    {-! derive: Binary !-}
hunk ./src/FrontEnd/Class.hs 107
-    classInsts = [],
hunk ./src/FrontEnd/Class.hs 108
+    classAlias = Nothing,
hunk ./src/FrontEnd/Class.hs 112
-combineClassRecords cra@(ClassRecord {}) crb@(ClassRecord {}) | className cra == className crb = ClassRecord {
-    className = className cra,
-    classSrcLoc = if classSrcLoc cra == bogusASrcLoc then classSrcLoc crb else classSrcLoc cra,
-    classSupers = snub $ classSupers cra ++ classSupers crb,
-    classInsts = snub $ classInsts cra ++ classInsts crb,
-    classAssumps = snubFst $ classAssumps cra ++ classAssumps crb,
-    classAssocs = snubUnder fst3 $ classAssocs cra ++ classAssocs crb,
-    classArgs = if null (classArgs cra) then classArgs crb else classArgs cra
-    }
-
-combineClassRecords cra@(ClassAliasRecord {}) crb@(ClassRecord {}) | className cra == className crb = ClassAliasRecord {
-    className = className cra,
-    classSrcLoc = if classSrcLoc cra == bogusASrcLoc then classSrcLoc crb else classSrcLoc cra,
-    classSupers = snub $ classSupers cra ++ classSupers crb,
-    classInsts = snub $ classInsts cra ++ classInsts crb,
-    classArgs = if null (classArgs cra) then classArgs crb else classArgs cra,
-    classClasses = classClasses cra,
-    classMethodMap = classMethodMap cra
-}
-
-combineClassRecords cra@(ClassRecord {}) crb@(ClassAliasRecord {}) = combineClassRecords crb cra
-combineClassRecords cra crb = error ("combineClassRecords ("++show cra++") ("++show crb++")")
-
-newtype InstanceEnv = InstanceEnv { instanceEnv :: Map.Map (Name,Name) ([Tyvar],[Tyvar],Type) }
+newtype InstanceEnv = InstanceEnv {
+    instanceEnv :: Map.Map (Name,Name) ([Tyvar],[Tyvar],Type) }
hunk ./src/FrontEnd/Class.hs 116
-makeInstanceEnv (ClassHierarchy ch) = InstanceEnv $ Map.fromList (concatMap f (Map.elems ch)) where
-    f cr = concatMap (g cr) (classInsts cr)
-    g cr Inst { instHead = _ :=> IsIn _cname tt, instAssocs = as } | _cname == className cr = ans where
+makeInstanceEnv (CH _ is) = InstanceEnv $ Map.fromList (concatMap f (Map.toList is)) where
+    f (cr,is) = concatMap (g cr) is
+    g cr Inst { instHead = _ :=> IsIn _cname tt, instAssocs = as } | _cname == cr = ans where
hunk ./src/FrontEnd/Class.hs 120
-    g cr x = error $  "makeInstanceEnv: " ++ show (className cr,x)
+    g cr x = error $  "makeInstanceEnv: " ++ show (cr,x)
hunk ./src/FrontEnd/Class.hs 127
-newtype ClassHierarchy = ClassHierarchy (Map.Map Class ClassRecord)
-    deriving (HasSize)
+data ClassHierarchy = CH (Map.Map Class ClassRecord) (Map.Map Class [Inst])
hunk ./src/FrontEnd/Class.hs 130
-    get = fmap ClassHierarchy getMap
-    put (ClassHierarchy ch) = putMap ch
+    get = do
+        m1 <- getMap
+        m2 <- getMap
+        return (CH m1 m2)
+    put (CH m1 m2) = do
+        putMap m1
+        putMap m2
hunk ./src/FrontEnd/Class.hs 139
-    mempty = ClassHierarchy mempty
-    mappend (ClassHierarchy a) (ClassHierarchy b) = ClassHierarchy $ Map.unionWith combineClassRecords a b
+    mempty = CH mempty mempty
+    mappend (CH a b) (CH c d) =
+        CH (Map.union a c) (Map.unionWith (++) b d)
hunk ./src/FrontEnd/Class.hs 144
-classRecords (ClassHierarchy ch) = Map.elems ch
+classRecords (CH ch _) = Map.elems ch
hunk ./src/FrontEnd/Class.hs 146
-findClassRecord (ClassHierarchy ch) cn = case Map.lookup cn ch of
+findClassRecord (CH ch _) cn = case Map.lookup cn ch of
hunk ./src/FrontEnd/Class.hs 150
-asksClassRecord (ClassHierarchy ch) cn f = case Map.lookup cn ch of
+asksClassRecord (CH ch _) cn f = case Map.lookup cn ch of
hunk ./src/FrontEnd/Class.hs 153
+findClassInsts (CH _ is) cn = fromMaybe [] (Map.lookup cn is)
hunk ./src/FrontEnd/Class.hs 170
-printClassSummary (ClassHierarchy h) = mapM_ f $  h' where
-    h' = [ (n,fromJust $ Map.lookup n h) | n <- (map fst [ (cn, classSupers ss) | (cn,ss) <- Map.toList h]) ]
-    f (cname, (ClassRecord { classSupers = supers, classInsts = insts, classAssumps = ma})) = do
-        putStrLn $ "-- class: " ++ show cname
-        unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers)
-        unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts))
-        putStrLn ""
-    f (cname, (ClassAliasRecord { classSupers = supers, classInsts = insts, classClasses = classes })) = do
+printClassSummary (CH h is) = mapM_ f (Map.toList h) where
+    --h' = [ (n,fromJust $ Map.lookup n h) | n <- (map fst [ (cn, classSupers ss) | (cn,ss) <- Map.toList h]) ]
+    f (cname, ClassRecord { .. }) = do
hunk ./src/FrontEnd/Class.hs 174
-        unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers)
+        let insts = fromMaybe [] (Map.lookup cname is)
+        unless (null classSupers) $ putStrLn $ "super classes:" ++ unwords (map show classSupers)
hunk ./src/FrontEnd/Class.hs 177
-        unless (null classes) $ putStrLn $ "alias for: " ++ unwords (map show classes)
-        putStrLn ""
+--        putStrLn ""
+--    f (cname, (ClassAliasRecord { classSupers = supers, classInsts = insts, classClasses = classes })) = do
+--        putStrLn $ "-- class: " ++ show cname
+--        unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers)
+--        unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts))
+--        unless (null classes) $ putStrLn $ "alias for: " ++ unwords (map show classes)
+--        putStrLn ""
hunk ./src/FrontEnd/Class.hs 186
-printClassHierarchy (ClassHierarchy h) = mapM_ printClassDetails $  Map.toList h where
+printClassHierarchy (CH h is) = mapM_ printClassDetails $  Map.toList h where
hunk ./src/FrontEnd/Class.hs 189
-        let args = classArgs cr; supers = classSupers cr; insts = classInsts cr;
-            -- possibly absent
+        let args = classArgs cr; supers = classSupers cr;
hunk ./src/FrontEnd/Class.hs 192
-            classes = classClasses cr
+        let insts = fromMaybe [] (Map.lookup cname is)
hunk ./src/FrontEnd/Class.hs 199
-        when (isClassRecord cr) $ do
+        when True $ do
hunk ./src/FrontEnd/Class.hs 204
-        when (isClassAliasRecord cr) $ do
+        when (isJust (classAlias cr)) $ do
+            let Just x = classAlias cr
hunk ./src/FrontEnd/Class.hs 207
-            pnone classes $ do putStrLn $ " " ++ (intercalate " " (map show classes))
+            putStrLn (pprint x)
+            --Just $ --pnone classes $ do putStrLn $ " " ++ (intercalate " " (map show classes))
hunk ./src/FrontEnd/Class.hs 212
-    passoc (nk,as,mt) = text "type" <+> pprint nk <+> hsep (map pprint as) <> case mt of
-        Nothing -> empty
-        Just s -> text " = " <> pprint s
-
---------------------------------------------------------------------------------
-modifyClassRecord ::  (ClassRecord -> ClassRecord) -> Class -> ClassHierarchy -> ClassHierarchy
-modifyClassRecord f c (ClassHierarchy h) = case Map.lookup c h of
-           --Nothing -> error $ "modifyClassRecord: " ++ show c
-           Nothing -> ClassHierarchy $ Map.insert c (f (newClassRecord c)) h
-           Just r -> ClassHierarchy $ Map.insert c (f r) h
-
-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)
+    passoc (Assoc nk isData as kt) = text (if isData then "data" else "type") <+>
+        pprint nk <+> hsep (map pprint as) <+> text "::" <+> pprint kt
hunk ./src/FrontEnd/Class.hs 216
-addOneInstanceToHierarchy ch inst@Inst { instHead = cntxt :=> IsIn className _ } = modifyClassRecord f className ch where
-    f c = c { classInsts = inst:classInsts c }
+addOneInstanceToHierarchy (CH r i) inst@Inst { instHead = cntxt :=> IsIn className _ } =
+    CH r (Map.insertWith (++) className [inst] i)
hunk ./src/FrontEnd/Class.hs 220
-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 }
+addInstanceToHierarchy inst@Inst { instHead = cntxt :=> IsIn className _ } (CH r i) =
+    CH r (Map.insertWith cd className [inst] i) where
+        cd [inst] cs = runIdentity $ ensureNotDup (instSrcLoc inst) inst cs
hunk ./src/FrontEnd/Class.hs 241
-{-
--- derive statements
-hsInstDeclToInst kt (HsDataDecl _sloc _cntxt tyConName argNames _condecls derives@(_:_))
-   = return $ map ((,) True) newInstances
-   where
-   tyConKind = kindOf (toName TypeConstructor tyConName) kt
-   flatTyConKind = unfoldKind tyConKind
-   argTypeKind = foldr1 Kfun $ drop (length argNames) flatTyConKind
-   argsAsTypeList = map (\n -> HsTyVar n) argNames
-   typeKindPairs :: [(HsType, Kind)]
-   typeKindPairs = (HsTyCon tyConName, tyConKind) : zip argsAsTypeList flatTyConKind
-   convertedType :: Type
-   convertedType = convType typeKindPairs
-   --newContext = map (hsAsstToPred kt) cntxt
-   --newInstances = makeDeriveInstances newContext convertedType derives
-   newInstances = mempty
-
-hsInstDeclToInst kt (HsNewTypeDecl _sloc _cntxt tyConName argNames _condecls derives@(_:_))
-   = return $ map ((,) True) newInstances
-   where
-   tyConKind = kindOf (toName TypeConstructor tyConName) kt
-   flatTyConKind = unfoldKind tyConKind
-   argTypeKind = foldr1 Kfun $ drop (length argNames) flatTyConKind
-   argsAsTypeList = map (\n -> HsTyVar n) argNames
-   typeKindPairs :: [(HsType, Kind)]
-   typeKindPairs = (HsTyCon tyConName, tyConKind) : zip argsAsTypeList flatTyConKind
-   convertedType :: Type
-   convertedType = convType typeKindPairs
-   --newContext = map (hsAsstToPred kt) cntxt
-   --newInstances = makeDeriveInstances newContext convertedType derives
-   newInstances = mempty
-
--- the types will only ever be constructors or vars
-
-convType :: [(HsType, Kind)] -> Type
-convType tsks = foldl1 tAp (map toType tsks)
-
-toType :: (HsType, Kind) -> Type
-toType (HsTyCon n, k) = TCon $ Tycon (toName TypeConstructor n) k
-toType (HsTyVar n, k) = TVar $ tyvar (toName TypeVal n) k
-toType (HsTyFun x y, Star) = TArrow (toType (x,Star)) (toType (y,Star))
-toType x = error $ "toType: " ++ show x
--}
-
hunk ./src/FrontEnd/Class.hs 251
-createClassAssocs kt decls = [ (ctc n,map ct as,ctype t)| HsTypeDecl { hsDeclName = n, hsDeclTArgs = as, hsDeclType = t } <- decls ] where
+createClassAssocs kt decls = [ Assoc (ctc n) False (map ct as) (ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = as, hsDeclType = t } <- decls ] where
hunk ./src/FrontEnd/Class.hs 254
-    ctype HsTyAssoc = Nothing
-    ctype t = Just $ runIdentity $ hsTypeToType kt t
+    ctype HsTyAssoc = kindStar
+--    ctype t = Just $ runIdentity $ hsTypeToType kt t
hunk ./src/FrontEnd/Class.hs 269
-instanceToTopDecls kt ch@(ClassHierarchy classHierarchy) (HsInstDecl _ qualType methods)
+instanceToTopDecls kt ch@(CH classHierarchy _) (HsInstDecl _ qualType methods)
hunk ./src/FrontEnd/Class.hs 278
-instanceToTopDecls kt ch@(ClassHierarchy classHierarchy) (HsClassDecl _ qualType methods)
+instanceToTopDecls kt ch@(CH classHierarchy _) (HsClassDecl _ qualType methods)
hunk ./src/FrontEnd/Class.hs 286
-instanceToTopDecls kt ch@(ClassHierarchy classHierarchy) cad@(HsClassAliasDecl {})
-   = unzip $ map (aliasDefaultMethodToTopDecls kt methodSigs aliasName) $ methodGroups where
-   aliasName = toName ClassName (hsDeclName cad)
-   methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x) (hsDeclDecls cad))
-   methodSigs = case Map.lookup aliasName classHierarchy  of
-           Nothing -> error $ "aliasDefaultInstanceToTopDecls: could not find class "
-                              ++ show aliasName ++ "in class hierarchy"
-           Just sigs -> concatMap (classAssumps . findClassRecord ch) (classClasses sigs)
+--instanceToTopDecls kt ch@(CH classHierarchy _) cad@(HsClassAliasDecl {})
+--   = unzip $ map (aliasDefaultMethodToTopDecls kt methodSigs aliasName) $ methodGroups where
+--   aliasName = toName ClassName (hsDeclName cad)
+--   methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x) (hsDeclDecls cad))
+--   methodSigs = case Map.lookup aliasName classHierarchy  of
+--           Nothing -> error $ "aliasDefaultInstanceToTopDecls: could not find class "
+--                              ++ show aliasName ++ "in class hierarchy"
+--           Just sigs -> concatMap (classAssumps . findClassRecord ch) (classClasses sigs)
hunk ./src/FrontEnd/Class.hs 311
-methodToTopDecls ch kt preds crecord@(ClassAliasRecord {}) qt meth@(methodName, methodDecls)
-   = methodToTopDecls ch kt preds (findClassRecord ch cls) qt meth
-     where Just cls = Map.lookup methodName (classMethodMap crecord)
+--methodToTopDecls ch kt preds crecord@(ClassAliasRecord {}) qt meth@(methodName, methodDecls)
+--   = methodToTopDecls ch kt preds (findClassRecord ch cls) qt meth
+--     where Just cls = Map.lookup methodName (classMethodMap crecord)
hunk ./src/FrontEnd/Class.hs 398
+scatterAliasInstances = id
+{-
hunk ./src/FrontEnd/Class.hs 422
+-}
hunk ./src/FrontEnd/Class.hs 427
-classHierarchyFromRecords rs = ClassHierarchy $ Map.fromListWith combineClassRecords [  (className x,x)| x <- rs ]
+classHierarchyFromRecords rs =
+    CH (Map.fromList [ (className x,x)| x <- rs ]) mempty
hunk ./src/FrontEnd/Class.hs 430
--- I love tying el knot.
hunk ./src/FrontEnd/Class.hs 431
-makeClassHierarchy (ClassHierarchy ch) kt ds = (ClassHierarchy ans) where
-    ans =  Map.fromListWith combineClassRecords [  (className x,x)| x <- execWriter (mapM_ f ds) ]
+makeClassHierarchy (CH ch _is) kt ds = ans where
+    ans =  execWriter (mapM_ f ds) -- Map.fromListWith combineClassRecords [  (className x,x)| x <- execWriter (mapM_ f ds) ]
hunk ./src/FrontEnd/Class.hs 437
-            tell [ClassRecord { classArgs = classArgs, classAssocs = classAssocs, className = toName ClassName className, classSrcLoc = sl, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- [], nameName n == className], classAssumps = qualifiedMethodAssumps }]
+            tell $ classHierarchyFromRecords [ClassRecord {
+                classArgs,
+                classAssocs,
+                classAlias = Nothing,
+                className = toName ClassName className,
+                classSrcLoc = sl,
+                classSupers = [ toName ClassName x | HsAsst x _ <- cntxt],
+                --classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- [], nameName n == className],
+                classAssumps = qualifiedMethodAssumps }]
hunk ./src/FrontEnd/Class.hs 452
-    f decl@(HsClassAliasDecl {}) = trace ("makeClassHierarchy: "++show decl) $ do
-        tell [ClassAliasRecord { className = toName ClassName (hsDeclName decl),
-                                 classArgs = [v | ~(TVar v) <- map (runIdentity . hsTypeToType kt) (hsDeclTypeArgs decl)],
-                                 classSrcLoc = hsDeclSrcLoc decl,
-                                 classSupers = [toName ClassName n | HsAsst n _ <- (hsDeclContext decl)],
-                                 classClasses = [toName ClassName n | HsAsst n _ <- (hsDeclClasses decl)],
-                                 classInsts = [],
-                                 classMethodMap = Map.empty
-                               }]
+--    f decl@(HsClassAliasDecl {}) = trace ("makeClassHierarchy: "++show decl) $ do
+--        tell [ClassAliasRecord { className = toName ClassName (hsDeclName decl),
+--                                 classArgs = [v | ~(TVar v) <- map (runIdentity . hsTypeToType kt) (hsDeclTypeArgs decl)],
+--                                 classSrcLoc = hsDeclSrcLoc decl,
+--                                 classSupers = [toName ClassName n | HsAsst n _ <- (hsDeclContext decl)],
+--                                 classClasses = [toName ClassName n | HsAsst n _ <- (hsDeclClasses decl)],
+--                                 classInsts = [],
+--                                 classMethodMap = Map.empty
+--                               }]
hunk ./src/FrontEnd/Class.hs 463
-        crs <- flip mapM [ (cn,i) | i@Inst { instHead = _ :=> IsIn cn _} <- insts] $ \ (x,inst) -> case Map.lookup x ch of
-            Just cr -> ensureNotDup (srcLoc decl) inst (classInsts cr) >> return [cr { classInsts = mempty }]
-            Nothing -> return [] -- case Map.lookup x ans of
+        -- TODO check for duplicates here?
+        --
+        --crs <- flip mapM [ (cn,i) | i@Inst { instHead = _ :=> IsIn cn _} <- insts] $ \ (x,inst) -> case Map.lookup x ch of
+        --    Just cr -> ensureNotDup (srcLoc decl) inst (classInsts cr) >> return [cr { classInsts = mempty }]
+        --    Nothing -> return [] -- case Map.lookup x ans of
hunk ./src/FrontEnd/Class.hs 470
-        case foldl addOneInstanceToHierarchy (classHierarchyFromRecords (concat crs)) insts of
-                ClassHierarchy ch -> tell $ Map.elems ch
+        tell $ foldl addOneInstanceToHierarchy mempty insts
hunk ./src/FrontEnd/Tc/Class.hs 126
-instsOf ch c = asksClassRecord ch c classInsts
+--instsOf ch c = asksClassRecord ch c classInsts
+instsOf ch c = findClassInsts ch c
hunk ./src/FrontEnd/Tc/Module.hs 196
-    let myClassAssumps = concat  [ classAssumps as | as <- classRecords cHierarchyWithInstances, isClassRecord as ]
+    let myClassAssumps = concat  [ classAssumps as | as <- classRecords cHierarchyWithInstances ]
hunk ./src/Ho/Binary.hs 22
-current_version = 6
+current_version = 8
hunk ./src/Ho/Build.hs 790
-        putStrLn $ "hoClassHierarchy:" <+> tshow (size $  hoClassHierarchy hoE)
+        putStrLn $ "hoClassHierarchy:" <+> tshow (length $ classRecords $ hoClassHierarchy hoE)