[Class aliases halfway done?
Samuel Bronson <naesten@gmail.com>**20080315015152] hunk ./FrontEnd/Class.hs 13
+    scatterAliasInstances,
hunk ./FrontEnd/Class.hs 28
+import Debug.Trace
hunk ./FrontEnd/Class.hs 73
-data ClassRecord = ClassRecord {
-    className :: Class,
-    classSrcLoc :: SrcLoc,
-    classArgs :: [Tyvar],
-    classSupers :: [Class],
-    classInsts :: [Inst],
-    classAssumps :: [(Name,Sigma)], -- ^ method signatures
-    classAssocs :: [(Tycon,[Tyvar],Maybe Sigma)]
-    }
-    {-! derive: Binary !-}
+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],
+                                      classScatterMap :: Map.Map Class [Name]
+                                    }
+    deriving Show
+    {-! derive: Binary, is !-}
hunk ./FrontEnd/Class.hs 102
-combineClassRecords cra crb | className cra == className crb = ClassRecord {
+combineClassRecords cra@(ClassRecord {}) crb@(ClassRecord {}) | className cra == className crb = ClassRecord {
hunk ./FrontEnd/Class.hs 112
+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,
+    classScatterMap = classScatterMap cra
+}
hunk ./FrontEnd/Class.hs 122
+combineClassRecords cra@(ClassRecord {}) crb@(ClassAliasRecord {}) = combineClassRecords crb cra
+combineClassRecords cra crb = error ("combineClassRecords ("++show cra++") ("++show crb++")")
hunk ./FrontEnd/Class.hs 187
+    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 ./FrontEnd/Class.hs 199
-    printClassDetails (cname, (ClassRecord { classArgs = classArgs, classSupers = supers, classInsts = insts, classAssumps = methodAssumps, classAssocs = classAssocs})) = do
+    printClassDetails (cname, cr) = do
+        let args = classArgs cr; supers = classSupers cr; insts = classInsts cr;
+            -- possibly absent
+            methodAssumps = classAssumps cr
+            assocs = classAssocs cr
+            classes = classClasses cr
hunk ./FrontEnd/Class.hs 206
-        putStrLn $ "class: " ++ hsep (pprint cname:map pprint classArgs)
+        putStrLn $ "class: " ++ hsep (pprint cname:map pprint args)
hunk ./FrontEnd/Class.hs 211
-        putStr $ "method signatures:"
-        pnone methodAssumps $ putStr $ "\n" ++ (unlines $ map pretty methodAssumps)
-        putStr $ "associated types:"
-        pnone classAssocs $  putStrLn $ "\n" ++ (unlines $ map (render . passoc) classAssocs)
+        when (isClassRecord cr) $ do
+            putStr $ "method signatures:"
+            pnone methodAssumps $ putStr $ "\n" ++ (unlines $ map pretty methodAssumps)
+            putStr $ "associated types:"
+            pnone assocs $  putStrLn $ "\n" ++ (unlines $ map (render . passoc) assocs)
+        when (isClassAliasRecord cr) $ do
+            putStr $ "alias for:"
+            pnone classes $ do putStrLn $ " " ++ (intercalate " " (map show classes))
hunk ./FrontEnd/Class.hs 344
+instanceToTopDecls kt (ClassHierarchy classHierarchy) cad@(HsClassAliasDecl {})
+    = error ("instanceToTopDecls: "++show cad)
hunk ./FrontEnd/Class.hs 353
-
+aliasDefaultInstanceName n ca = toName Val $ Qual (Module "Instance@") $ HsIdent ('i':show n ++ ".default." ++ ca)
hunk ./FrontEnd/Class.hs 369
-        _ -> error $ "sigFromClass: " ++ pprint (classAssumps crecord) ++ " " ++ show  methodName
+        _ -> error $ "sigFromClass: " ++ (pprint className <+> pprint (classAssumps crecord))
+                                      ++ " " ++ show  methodName
hunk ./FrontEnd/Class.hs 438
+scatterAliasInstances :: Monad m => ClassHierarchy -> m ClassHierarchy
+scatterAliasInstances ch = do
+  let cas = [cr | cr@(ClassAliasRecord {}) <- classRecords ch]
+  fail ("scatterAliasInstances: " ++ show cas)
+      
+--------------------------------------------------------------------------------
hunk ./FrontEnd/Class.hs 447
-classHierarchyFromRecords rs =  ClassHierarchy $ Map.fromListWith combineClassRecords [  (className x,x)| x <- rs ]
+classHierarchyFromRecords rs = ClassHierarchy $ Map.fromListWith combineClassRecords [  (className x,x)| x <- rs ]
hunk ./FrontEnd/Class.hs 464
-    f decl = hsInstDeclToInst kt decl >>= \insts -> do
+    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 = [],
+                                 classScatterMap = mempty
+                               }]
+            
+    f decl@(HsInstDecl {}) = hsInstDeclToInst kt decl >>= \insts -> do
hunk ./FrontEnd/HsParser.y 28
-
+import Control.Monad (liftM, liftM2)
+import Debug.Trace (trace)
hunk ./FrontEnd/HsParser.y 110
+      'alias'         { KW_Alias }
hunk ./FrontEnd/HsParser.y 299
+      | 'class' 'alias' srcloc conid varids '=' carhs optcbody
+                      {% let
+                         { (cxt, clss) = $7;
+                           ret = HsClassAliasDecl { hsDeclSrcLoc = $3, hsDeclName = $4, hsDeclTypeArgs = map HsTyVar $5, hsDeclContext = cxt, hsDeclClasses = clss, hsDeclDecls =$8 }
+                         } in trace ("\n"++show ret++"\n") (return ret)
+                      }
hunk ./FrontEnd/HsParser.y 325
+
hunk ./FrontEnd/HsParser.y 474
+carhs :: { (HsContext, HsContext) }
+       : btype '=>' btype {% liftM2 (,)     (checkContext $1) (checkContext $3) }
+       | btype            {% liftM ((,) []) (checkContext $1) }
+
hunk ./FrontEnd/HsParser.y 481
+
hunk ./FrontEnd/HsParser.y 840
+      | 'alias'               { UnQual (HsIdent "alias") }
hunk ./FrontEnd/HsPretty.hs 285
+
+ppHsDecl (HsClassAliasDecl pos name args context classes declList) =
+	   --blankline $
+	   mySep ([text "class alias", ppHsName name] ++ map ppHsType args
+                  ++ [equals, ppHsContext context, text "=>", ppHsContext classes, text "where"])
+	   $$$ body classIndent (map ppHsDecl declList)
hunk ./FrontEnd/HsSyn.hs 138
+    srcLoc HsClassAliasDecl { hsDeclSrcLoc = sl } = sl
hunk ./FrontEnd/HsSyn.hs 191
+    | HsClassAliasDecl {
+        hsDeclSrcLoc :: SrcLoc,
+        hsDeclName :: HsName,
+        hsDeclTypeArgs :: [HsType],
+        {- rhs -} hsDeclContext :: HsContext,
+                  hsDeclClasses :: HsContext,
+        hsDeclDecls :: [HsDecl]
+        }
hunk ./FrontEnd/KindInfer.hs 365
-kiInitClasses ds =  sequence_ [ f className [classArg] |  HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon className) (HsTyVar classArg))) _ <- ds] where
+kiInitClasses ds =  sequence_ [ f className [classArg] |  HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon className) (HsTyVar classArg))) _ <- ds]
+                    >> sequence_ [ f (hsDeclName cad) [v | HsTyVar v <- hsDeclTypeArgs cad]
+                                   | cad@(HsClassAliasDecl {}) <- ds ]
+    where
hunk ./FrontEnd/KindInfer.hs 373
-
hunk ./FrontEnd/Lexer.hs 95
+        | KW_Alias
hunk ./FrontEnd/Lexer.hs 162
+ ( "alias",     KW_Alias ),
hunk ./FrontEnd/Rename.hs 239
+    rename (HsClassAliasDecl srcLoc name args hsContext hsClasses hsDecls) = do
+        withSrcLoc srcLoc $ do
+        name' <- renameTypeName name
+        updateWith args $ do
+        args' <- mapM rename args
+        hsContext' <- rename hsContext
+        hsClasses' <- rename hsClasses
+        hsDecls' <- rename hsDecls
+        return (HsClassAliasDecl srcLoc name' args' hsContext' hsClasses' hsDecls')
hunk ./FrontEnd/Rename.hs 837
+    f cad@(HsClassAliasDecl { hsDeclSrcLoc = sl, hsDeclName = n, hsDeclDecls = ds }) 
+           = tellF $ (toName Name.ClassName n,sl,snub $ fsts cs):[ (n,a,[]) | (n,a) <- cs]
+        where 
+          cs = fst (mconcatMap (namesHsDeclTS' toName) ds)
+
hunk ./FrontEnd/Syn/Traverse.hs 234
+    f decl@(HsClassAliasDecl { hsDeclSrcLoc = sl})  = withSrcLoc sl $ do
+        hsDecls'  <- mapM (traverseHsDeclHsExp fn) (hsDeclDecls decl)
+        return (decl { hsDeclDecls = hsDecls' })
hunk ./FrontEnd/Tc/Module.hs 39
+--import ClassAliases
hunk ./FrontEnd/Tc/Module.hs 115
-    let fixityMap = thisFixityMap `mappend` hoFixities hoB
+    let fixityMap = thisFixityMap  `mappend` hoFixities hoB
hunk ./FrontEnd/Tc/Module.hs 117
-    let ts = thisTypeSynonyms  `mappend` hoTypeSynonyms hoB
+    let ts = thisTypeSynonyms `mappend` hoTypeSynonyms hoB
hunk ./FrontEnd/Tc/Module.hs 129
-    let classAndDataDecls = filter (or' [isHsDataDecl, isHsNewTypeDecl, isHsClassDecl]) ds  -- rDataDecls ++ rNewTyDecls ++ rClassDecls
+    let classAndDataDecls = filter (or' [isHsDataDecl, isHsNewTypeDecl, isHsClassDecl, isHsClassAliasDecl]) ds  -- rDataDecls ++ rNewTyDecls ++ rClassDecls
hunk ./FrontEnd/Tc/Module.hs 152
-    cHierarchyWithInstances <- return $ smallClassHierarchy `mappend` importClassHierarchy
+    cHierarchyWithInstances <- scatterAliasInstances $ smallClassHierarchy `mappend` importClassHierarchy