[perform dependency analysis on type synonyms before expansion, detect recursive synonyms.
John Meacham <john@repetae.net>**20090907110339
 Ignore-this: dbdc78dd0f53b0d4d88f5bde202859ce
] addfile ./regress/tests/4_bugs/rectypes.hs
hunk ./regress/tests/4_bugs/rectypes.hs 1
+type Foo = Bar
+type Bar = Foo
+
+main :: IO Foo
+main = return ()
addfile ./regress/tests/4_bugs/rectypes.mustfail
hunk ./src/FrontEnd/HsPretty.hs 384
+instance P.PPrint Doc HsType where
+    pprint = ppHsType
+
hunk ./src/FrontEnd/Syn/Traverse.hs 10
+import Name.Name
hunk ./src/FrontEnd/Syn/Traverse.hs 18
+instance FreeVars HsType (Set.Set Name) where
+    freeVars t = execWriter (f t) where
+        f (HsTyVar v) = tell (Set.singleton $ toName TypeVal v)
+        f (HsTyCon v) = tell (Set.singleton $ toName TypeConstructor v)
+        f t = traverseHsType_ f t
+
hunk ./src/FrontEnd/Tc/Module.hs 124
-    let thisTypeSynonyms =  (declsToTypeSynonyms $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])
+    --let thisTypeSynonyms =  (declsToTypeSynonyms $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])
+    thisTypeSynonyms <- declsToTypeSynonyms (hoTypeSynonyms htc) $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms]
+--    putStrLn "Synonyms"
+--    putStrLn $ HsPretty.render $ showSynonyms pprint thisTypeSynonyms
+
hunk ./src/FrontEnd/TypeSynonyms.hs 7
+    showSynonyms,
hunk ./src/FrontEnd/TypeSynonyms.hs 12
-import Data.Monoid
hunk ./src/FrontEnd/TypeSynonyms.hs 13
-import List
+import Data.List
+import Data.Monoid
hunk ./src/FrontEnd/TypeSynonyms.hs 16
+import qualified Data.Set as Set
hunk ./src/FrontEnd/TypeSynonyms.hs 18
+import Support.FreeVars
hunk ./src/FrontEnd/TypeSynonyms.hs 20
+import FrontEnd.HsSyn
hunk ./src/FrontEnd/TypeSynonyms.hs 22
-import GenUtil
-import Util.UniqueMonad
hunk ./src/FrontEnd/TypeSynonyms.hs 23
-import FrontEnd.HsSyn
-import Name.Name
-import Util.HasSize
hunk ./src/FrontEnd/TypeSynonyms.hs 24
+import GenUtil
+import Name.Name
hunk ./src/FrontEnd/TypeSynonyms.hs 27
+import Util.HasSize
+import Util.UniqueMonad
+import qualified Util.Graph as G
hunk ./src/FrontEnd/TypeSynonyms.hs 48
+showSynonyms :: DocLike d => (HsType -> d) -> TypeSynonyms -> d
+showSynonyms pprint (TypeSynonyms m) = vcat (map f (Map.toList m)) where
+    f (n,(ns,t,_)) =  hsep (tshow n:map tshow ns) <+> text "=" <+> pprint t
+
hunk ./src/FrontEnd/TypeSynonyms.hs 55
-declsToTypeSynonyms :: [HsDecl] -> TypeSynonyms
-declsToTypeSynonyms ts = TypeSynonyms $ Map.fromList $
-    [ (toName TypeConstructor name,( args , quantifyHsType args (HsQualType [] t) , sl)) | (HsTypeDecl sl name args' t) <- ts, let args = [ n | ~(HsTyVar n) <- args'] ]
-     ++ [ (toName TypeConstructor name,( args , HsTyAssoc, sl)) | (HsClassDecl _ _ ds) <- ts,(HsTypeDecl sl name args' _) <- ds, let args = [ n | ~(HsTyVar n) <- args'] ]
+--declsToTypeSynonyms :: [HsDecl] -> TypeSynonyms
+--declsToTypeSynonyms ts = TypeSynonyms $ Map.fromList $
+--    [ (toName TypeConstructor name,( args , quantifyHsType args (HsQualType [] t) , sl)) | (HsTypeDecl sl name args' t) <- ts, let args = [ n | ~(HsTyVar n) <- args'] ]
+--     ++ [ (toName TypeConstructor name,( args , HsTyAssoc, sl)) | (HsClassDecl _ _ ds) <- ts,(HsTypeDecl sl name args' _) <- ds, let args = [ n | ~(HsTyVar n) <- args'] ]
+
+-- | convert a set of type synonym declarations to a synonym map used for efficient synonym
+-- expansion, expanding out the body of synonyms along the way.
+
+declsToTypeSynonyms :: MonadWarn m => TypeSynonyms -> [HsDecl] -> m TypeSynonyms
+declsToTypeSynonyms tsin ds = f tsin gr [] where
+    gr = G.scc $ G.newGraph [ (toName TypeConstructor name,( args , quantifyHsType args (HsQualType [] t) , sl)) | (HsTypeDecl sl name args' t) <- ds, let args = [ n | ~(HsTyVar n) <- args'] ] fst (Set.toList . freeVars . (\ (_,(_,t,_)) -> t))
+    f tsin (Right ns:xs) rs = do
+            warn (head [ sl | (_,(_,_,sl)) <- ns]) "type-synonym-recursive" ("Recursive type synonyms:" <+> show (fsts ns))
+            f tsin xs rs
+    f tsin (Left (n,(as,body,sl)):xs) rs = do
+        body' <- removeSynonymsFromType tsin body
+        f (tsInsert n (as,body',sl) tsin) xs ((n,(as,body',sl)):rs)
+    f _ [] rs = return $ TypeSynonyms (Map.fromList rs)
+
+tsInsert x y (TypeSynonyms xs) = TypeSynonyms (Map.insert x y xs)
hunk ./src/FrontEnd/Warning.hs 96
+    "type-synonym-recursive",