[clean up FrontEnd.Class, add classAssocs to class record
John Meacham <john@repetae.net>**20061018022902] hunk ./FrontEnd/Class.hs 33
-    addClassToHierarchy,
-    addInstancesToHierarchy,
hunk ./FrontEnd/Class.hs 40
-    addOneInstanceToHierarchy,
hunk ./FrontEnd/Class.hs 64
-import GenUtil(snub,snubFst,concatInter)
hunk ./FrontEnd/Class.hs 76
+import Util.Gen
hunk ./FrontEnd/Class.hs 97
+    classAssocs :: [((Name,Kind),[(Name,Kind)],Maybe Sigma)],
hunk ./FrontEnd/Class.hs 108
+    classAssocs = [],
hunk ./FrontEnd/Class.hs 118
+    classAssocs = snubUnder fst3 $ classAssocs cra ++ classAssocs crb,
hunk ./FrontEnd/Class.hs 122
+fst3 (x,_,_) = x
+
hunk ./FrontEnd/Class.hs 157
-addClassToHierarchy :: Monad m =>  KindEnv -> HsDecl -> ClassHierarchy -> m ClassHierarchy
-addClassToHierarchy  kt (HsClassDecl _ t decls) (ClassHierarchy h) |   (HsQualType cntxt (HsTyApp (HsTyCon className') (HsTyVar argName')))  <- toHsQualType t = let
-   qualifiedMethodAssumps = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls)
-   newClassContext = [HsAsst (nameName className) [nameName argName]] -- [(className, argName)]
-   className,argName :: Name
-   className = toName ClassName className'
-   argName = toName TypeVal argName'
-   in return $ ClassHierarchy $ Map.insertWith combineClassRecords  className ClassRecord { classSrcLoc = bogusASrcLoc, className = className, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [], classDerives = [], classAssumps = qualifiedMethodAssumps } h
-
-
-addClassToHierarchy  _ _ ch = return ch
-
---addClassToHierarchy mod kt (HsClassDecl _sloc (HsUnQualType (HsTyApp (HsTyCon className) (HsTyVar argName))) decls) h
---   = addToEnv (className, ([], [], qualifiedMethodAssumps)) h
---   where
---   qualifiedMethodAssumps
---      = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isSigDecl decls)
---   newClassContext
---      = [(className, argName)]
---qualifyMethod cntxt (HsTypeSig sloc names (HsUnQualType t))
---   = HsTypeSig sloc names (HsQualType cntxt t)
hunk ./FrontEnd/Class.hs 179
-printClassHierarchy (ClassHierarchy h)
-   = mapM_ printClassDetails $  Map.toList h
-   where
-   printClassDetails :: (Name, ClassRecord) -> IO ()
-   printClassDetails (cname, (ClassRecord { classSupers = supers, classInsts = insts, classAssumps = methodAssumps}))
-      = do
-            putStrLn "..........."
-            putStrLn $ "class: " ++ show cname
-            putStr $ "super classes:"
-            case supers of
-               [] -> putStrLn $ " none"
-               _  -> putStrLn $ " " ++ (showListAndSep id " " (map show supers))
-            putStr $ "instances:"
-            case insts of
-               [] -> putStrLn $ " none"
-               _  -> putStrLn $ "\n" ++ (showListAndSepInWidth showInst 80 ", " insts)
-            putStr $ "method signatures:"
-            case methodAssumps of
-
-               [] -> putStrLn $ " none"
-               _  -> putStrLn $ "\n" ++
-                        (unlines $ map pretty methodAssumps)
+printClassHierarchy (ClassHierarchy h) = mapM_ printClassDetails $  Map.toList h where
+    printClassDetails :: (Name, ClassRecord) -> IO ()
+    printClassDetails (cname, (ClassRecord { classSupers = supers, classInsts = insts, classAssumps = methodAssumps, classAssocs = classAssocs})) = do
+        putStrLn "..........."
+        putStrLn $ "class: " ++ show cname
+        putStr $ "super classes:"
+        pnone supers $ do putStrLn $ " " ++ (concatInter " " (map show supers))
+        putStr $ "instances:"
+        pnone insts $  putStr $ "\n" ++ (showListAndSepInWidth showInst 80 ", " insts)
+        putStr $ "method signatures:"
+        pnone methodAssumps $ putStr $ "\n" ++ (unlines $ map pretty methodAssumps)
+        putStr $ "associated types:"
+        pnone classAssocs $  putStrLn $ "\n" ++ (unlines $ map (render . passoc) classAssocs)
+        putStr "\n"
+    pnone [] f = putStrLn " none"
+    pnone xs f = f
+    passoc (nk,as,mt) = text "type" <+> pb nk <+> hsep (map pb as) <> case mt of
+        Nothing -> empty
+        Just s -> text " = " <> pprint s
+    pb (n,Star) = pprint n
+    pb (n,k) = parens (pprint n <+> text "::" <+> pprint k)
hunk ./FrontEnd/Class.hs 202
-            putStr "\n"
-
hunk ./FrontEnd/Class.hs 205
-addInstancesToHierarchy :: Monad m => KindEnv -> ClassHierarchy -> [HsDecl] -> m ClassHierarchy
-addInstancesToHierarchy kt ch decls = do
-    insts <- mapM (hsInstDeclToInst kt) decls
-    return $ foldl addOneInstanceToHierarchy ch (concat insts)
-   --where
-   --instances = concatMap (hsInstDeclToInst kt) decls
hunk ./FrontEnd/Class.hs 545
-            tell [ClassRecord { className = toName ClassName className, classSrcLoc = sl, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classDerives = [], classAssumps = qualifiedMethodAssumps }]
+            tell [ClassRecord { classAssocs = classAssocs, className = toName ClassName className, classSrcLoc = sl, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classDerives = [], classAssumps = qualifiedMethodAssumps }]
hunk ./FrontEnd/Class.hs 550
+        classAssocs = [ (ct TypeConstructor n,map (ct TypeVal) as,ctype t)| HsTypeDecl { hsDeclName = n, hsDeclArgs = as, hsDeclType = t } <- decls ] where
+            ct nameType n = let nn = toName nameType n in (nn,kindOf nn kt)
+            ctype HsTyAssoc = Nothing
+            ctype t = Just $ runIdentity $ hsTypeToType kt t
hunk ./FrontEnd/Class.hs 569
--- takes a list of things and puts a seperator string after each elem
--- except the last, first arg is a function to convert the things into
--- strings
-showListAndSep :: (a -> String) -> String -> [a] -> String
-showListAndSep f sep [] = []
-showListAndSep f sep [s] = f s
-showListAndSep f sep (s:ss) = f s ++ sep ++ showListAndSep f sep ss
hunk ./FrontEnd/Class.hs 572
-accLen width (x:xs)
-   = let newWidth
-           = length x + width
-     in (newWidth, x) : accLen newWidth xs
+accLen width (x:xs) = let newWidth = length x + width in (newWidth, x) : accLen newWidth xs
hunk ./FrontEnd/Class.hs 591
-showListAndSepInWidth f width sep things
-   = unlines $ groupStringsToWidth width newThings
-   where
+showListAndSepInWidth f width sep things = unlines $ groupStringsToWidth width newThings where
hunk ./FrontEnd/ParseUtils.hs 59
+--	split a b = fail $ "Illegal data/newtype declaration: " ++ show (a,b)
hunk ./FrontEnd/ParseUtils.hs 103
+--checkSimple kw t ts = fail ("Illegal " ++ kw ++ " declaration: " ++ show (t,ts))