First shot at proper recdescent grapher.

Code is piss-shit ugly, will be refactored.

src/GraphType.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternGuards #-}
 module Main where
 
 import Parse (parseFiles)
@@ -6,6 +7,8 @@ import Language.Haskell.Exts
 import Data.Generics.PlateData (universeBi)
 import Text.Dot
 import Data.List
+import Data.Maybe
+import Control.Monad
 
 -- | Drawing depth
 data Depth = Inf | Limit Int
@@ -22,27 +25,65 @@ main = do
   let graph = buildGraph types Inf "Organization"
   writeFile "output.dot" graph
 
-
-buildGraph types depth root = showDot $ do
-  explainType types root
-
-
-explainType types root = cluster $ do
-  -- 't' stands for 'type'
-  let t = findType types root
-
-  attribute ("label", getName t)
-
-  sequence_ [ explainConstructor c | c <- universeBi t ]
+buildGraph types depth root = 
+  showDot $ do
+    attribute("compound", "true")
+    (danglingLinks,clusters) <- addDataDecl root [] types
+    addLinks danglingLinks clusters types
+
+addLinks :: Links -> Clusters -> [Decl] -> Dot ()
+addLinks [] clusters types = return ()
+addLinks links@((node,port,decl):rest) clusters types = 
+  case lookup decl clusters of
+    -- We already have drawn this cluster. Just add link to it
+    Just (destCluster, destNode) -> do
+      edge' node (Just port) destNode Nothing [("lhead",show destCluster)] 
+      -- destination port is set to nothing because we really just want to get to the 
+      -- edge of the destination cluster and that's it
+      addLinks rest clusters types
+    -- Cluster for type 'decl' is absent. Add it.
+    Nothing -> do
+      (danglingLinks, clusters') <- addDataDecl decl clusters types
+      addLinks (links++danglingLinks) clusters' types
+
+type Clusters = [(String, (NodeId, NodeId))] -- Declaration name -> (cluster, node in cluster)
+type Links = [(NodeId,String,String)]
+addDataDecl :: String -> Clusters -> [Decl] -> Dot (Links,Clusters)  
+addDataDecl root clusters types = do
+  ( cluster_id, (dest_node, dangling_links) ) <- cluster $ do
+    let (Just t) = findType root types
+
+    attribute ("label", getName t)
+
+    (nodes, links) <- liftM unzip $ sequence $ umap addConstructor t
+    return (head' nodes, concat links)
+  return ( dangling_links, (root, (cluster_id, dest_node)):clusters ) 
   where
-    collect f t = foldr1 (<||>) $ [ f c | c <- universeBi t ]
-
-    explainConstructor (ConDecl nm types) = record $ block $ ("ConDecl " ++ fromName nm) <//> collect explainType types
-    explainConstructor (RecDecl nm types) = record $ block $ ("RecDecl " ++ fromName nm) <//> block (foldr1 (<||>) $ map pp types)
-      where pp (nm,t) = concatMap prettyPrint nm ++ "::" ++ prettyPrint t
-
-    explainType (TyCon qname) = prettyPrint qname
-
+    head' [] = userNodeId (-1)
+    head' ns = head ns
+    addConstructor (ConDecl nm types) = do
+      let recordFields = umap typeToField types
+      nodeId <- record $ block $ ("ConDecl " ++ fromName nm) <//> ( block $ toLabel recordFields )
+      return (nodeId, map (\(p,t) -> (nodeId,p,t)) $ catMaybes $ map snd recordFields)
+    addConstructor (RecDecl nm types) = do
+      let recordFields = umap typeToField $ map snd types
+      nodeId <- record $ block $ ("RecDecl " ++ fromName nm) <//> ( block $ toLabel recordFields ) --block (foldr1 (<||>) $ map pp types)
+      return (nodeId, map (\(p,t) -> (nodeId,p,t)) $ catMaybes $ map snd recordFields)
+
+    typeToField (TyCon qname) = 
+      case findType label types of
+                 Just t  -> ( port ++ " " ++ label, Just (port, label) ) -- FIXME
+                 Nothing -> ( label, Nothing )
+      where
+        label = prettyPrint qname
+        port = "<"++label++">"
+    typeToField _ = ( "bogus" , Nothing )
+
+    toLabel [] = ""
+    toLabel fields = foldr1 (<||>) $ map fst fields
+
+umap f l = [ f x | x <- universeBi l ]
+
 -- Graph nodes construction helpers
 box label = node $ [ ("shape","box"),("label",label) ]
 record label = node $ [ ("shape","record"),("label",label) ]
@@ -56,15 +97,12 @@ block x = "{ " ++ x ++ " }"
 
 -- Haskell AST manipulation helpers
 
--- TODO: Mb process Map, [] etc in a special way here
-findType types nm =
-  case find ((==nm).getName) types of
-    Just t -> t
-    -- TODO: it might be better to just die here
-    Nothing -> error $ "Failed to fetch definition of " ++ nm
+findType nm types = find ((==nm).getName) types
 
 getName (DataDecl _ _ _ nm _ _ _) = fromName nm
 getName (TypeDecl _ nm _ _) = fromName nm
 
 fromName (Ident x) = x
-fromName (Symbol x) = x
+fromName (Symbol x) = x
+
+names ns = concat $ intersperse ", " $ map fromName ns