forked from adept/graphtype
-
Notifications
You must be signed in to change notification settings - Fork 1
/
GraphType.hs
245 lines (210 loc) · 11.5 KB
/
GraphType.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
-- | TODO: top-level docs
module Main where
import Parse (parseFiles)
import OptionParser
import Language.Haskell.Exts
import Data.Generics.PlateData (universeBi)
import Text.Dot
import Data.List
import Data.Maybe
import Control.Monad
main = do
(Mode depth output, root, files) <- getOpts
types <- parseFiles files
let graph = buildGraph types depth root
writeFile output graph
type DeclName = String
type Graph = String
-- | Builds dependency graph starting with datatype declaration `root'.
-- Recursively expands all user-defined `types' referenced from `root', up to `depth'
-- TODO: use depth
buildGraph :: [Decl] -- ^ All declarations found in source files
-> Maybe Int -- ^ Recursion depth
-> DeclName -- ^ Start from this declaration
-> Graph -- ^ Graph definition in DOT syntax
buildGraph types depth root =
showDot $ do
-- Allow links that end on cluster boundaries
attribute("compound", "true")
-- Try harder to route edges around clusters
attribute("remincross", "true")
-- Try harder to route edges around clusters
-- attribute("rankdir", "LR")
-- Add topmost declaration and proceed with links going from it
(danglingLinks,clusters) <- addDecl root [] types
addLinks danglingLinks clusters types
-- Each declaration is transformed to the cluster on the output graph.
-- Elements of the cluster are graph nodes, one for each constructor in the declaration.
-- Those nodes have shape "record".
-- Since there are "records" with "fields" in dot syntax, and "records" with "fields" in Haskell syntax,
-- there bound to be some misunderstanding. Unless said otherwise, from now on records and fields
-- are those from dot syntax.
type Links = [DanglingLink]
-- | Information about dangling link that should be added to graph.
-- We would want to create links while in the middle of constructing a complex record node, which is not possible.
-- Thus, all outgoing links are scheduled in the list of dangling links and resolved in the breadth-first manner.
-- Initially, each dangling link is specified via target declaration name. When this declaration is added to graph,
-- it is possible to find out cluster id and (some) node id corresponding to that declaration and actually build a link.
--
-- We have to have some target node id because dot does not allow links to clusters themselves. We choose first node
-- within a cluster as our target.
data DanglingLink =
DL { linkTarget::DeclName -- ^ destination declaration to link to
, createLink::(ClusterId -> NodeId -> Dot ()) -- ^ function used to create link once proper destination cluster is determined
}
type ClusterId = NodeId
type Port = String
-- | Helper constructor for dangling links.
-- Notice the 'head" attribute - without it the edge would not stop at the cluster boundary
mkDL :: DeclName -> Port -> NodeId -> DanglingLink
mkDL target sourcePort sourceNode =
DL target (\cluster targetNode -> edge' sourceNode (Just sourcePort) targetNode Nothing [("lhead",show cluster)])
-- | Information about clusters already added to the graph:
-- (Declaration name, (cluster id for this declaration, Id of the first node in this cluster))
type Clusters = [(DeclName, (NodeId, NodeId))]
-- | Add dangling `links' to the graph, adding new clusters as needed
addLinks :: Links -- ^ Links to be added to the graph
-> Clusters -- ^ Clusters already present in graph
-> [Decl] -- ^ All declarations parsed from source files
-> Dot ()
addLinks [] clusters types = return ()
addLinks links@((DL target mkLink):rest) clusters types =
case lookup target clusters of
Just (destCluster, destNode) -> do
-- Target cluster is already in the graph. Just add link to it and proceed
mkLink destCluster destNode
addLinks rest clusters types
Nothing -> do
-- Target cluster is absent. Add it and re-try linking.
(danglingLinks, clusters') <- addDecl target clusters types
addLinks (links++danglingLinks) clusters' types
-- | Each "record" node in the dot file could be decomposed into several fields.
-- Each field represents a Haskell record field, Haskell datatype component or Haskell type declaration
data Field = F { fieldName::Maybe Name -- ^ name of the Haskell record field, empty otherwise
, fieldPort::Maybe Port -- ^ dot-specific ID of the field, for anchoring originating links. Empty when field has some unknown type
, typeName::DeclName -- ^ user-friendly name of the Haskell type
, fieldLink::[Maybe (NodeId -> DanglingLink)] -- ^ As soon as DOT record is finished, its node id is substituted here to
-- obtain a dangling link to target declaration. Empty when field has some unknown type
}
-- | Add a single declaration to graph. As it was already said, each declaration is mapped to a DOT cluster
addDecl :: DeclName -- ^ Name of the declaration we are adding
-> Clusters -- ^ Declarations already added to graph
-> [Decl] -- ^ All known declarations
-> Dot (Links,Clusters) -- ^ ( Links dangling from this declaration, Updated list of clusters )
addDecl declName clusters decls = do
( clusterId, (firstNodeId, danglingLinks) ) <- mkCluster
let clusters' = (declName, (clusterId, firstNodeId)):clusters
return ( danglingLinks, clusters' )
where
-- Find declaration by name
d = case findDecl declName decls of
Just x -> x
Nothing -> error $ "Could not find type " ++ declName ++ " in source files"
-- Type, newtype or data
declType = getDeclType d
mkCluster = cluster $ do
attribute ( "label", unwords [ declType, getName d ] )
if declType == "type"
then do
-- For simple type declaration, convert all type components to DOT record fields
let (TypeDecl _ _ _ t) = d
let fs = type2fields 0 t
-- Then, convert DOT fields to DOT record.
-- Type components will be separated into different "cells" of the record, so that
-- it would be possible to create outgoing links from any type component.
mkRecord ( mkLabel fs ) fs
else do
-- For data/newtype declaration, create a single record for each constructor.
(constructorNodes, links) <- liftM unzip $ sequence $ [ addConstructor x | x <- universeBi d ]
-- Collect all outgoing links.
return (head constructorNodes, concat links)
mkRecord :: String -> [Field] -> Dot (NodeId, Links)
mkRecord label fs = do
-- Create DOT record node
rId <- record label
-- Instantiate all outgoing links
let links = [ mkLink rId | (F _ _ _ links) <- fs, Just mkLink <- links ]
return (rId, links)
-- Produce label for record.
-- Since label has both human-readable components and special markup that defines record shape,
-- special care should be taken while combining information from separate fields:
mkLabel :: [Field] -> String
mkLabel fs = wrap $ toLabel $ map mkComponent fs
where
mkComponent field
-- If field is not named (body of type or component of data), then label is just "<port> type_name":
| fieldName field == Nothing = mkPort field ++ typeName field
-- If field is named, that we should take care to:
-- 1)Preserve position of the topmost port
-- 2)Enclose all complex declarations in {}
| otherwise = let fn = fromName $ fromJust $ fieldName field -- Haskell field name
t = typeName field -- Haskell type
text = case head t of
-- If the type is complex (Map Foo Bar), include complex description as DOT subfield
'{' -> block $ fn ++ " :: | " ++ block t
-- If the type is simple, just prepend field name
_ -> fn ++ " :: " ++ t
-- Dont forget the port (if present)
in mkPort field ++ text
mkPort f = fromMaybe "" $ fieldPort f
toLabel [] = ""
toLabel fields = foldr1 (<||>) fields
-- When combining more that one field into label, enclose it in {}
wrap = case fs of
[_] -> id
_ -> block
-- TODO: add InfixConDecl
addConstructor (ConDecl nm types) = do
let fs = concat $ zipWith type2fields [0..] types
fields2record ("constructor " ++ fromName nm) fs
addConstructor (RecDecl nm types) = do
let fs = zipWith rectype2field [0..] types
fields2record ("record " ++ fromName nm) fs
-- DOT records for Haskell data and Haskell record have "header" with the name of the constructor
fields2record header fs = mkRecord ( header <//> mkLabel fs ) fs
-- Collect all type constructors mentioned in type and convert them into DOT fields.
-- `x' would be explained below
type2fields x t = map (tyCon2field x) cons
where cons = [ prettyPrint qname | TyCon qname <- universeBi t ] -- TODO: process TyInfix as well
-- Convert type `typeName' into DOT field
tyCon2field x typeName =
case findDecl typeName decls of
-- If this is a known (user-defined) type, allocate a port for link and add a dangling link to expanded type description
Just d -> F {fieldName=Nothing, fieldPort=Just port, typeName=typeName, fieldLink=[Just (mkDL typeName port)]}
-- If this is a library type, just record its name
Nothing -> F {fieldName=Nothing, fieldPort=Nothing, typeName=typeName, fieldLink=[Nothing]}
where
-- Allocate port. Port name is similar to type name, with sequential number X appended to distinguish between several
-- components of the same type within a single declaration
port = concat [ "<", typeName, show x, "> " ]
-- Convert Haskell record field into DOT record field
rectype2field x (nms,t) =
let fs = type2fields x t -- first, conver all type components into fields
fName = concat $ intersperse ", " $ map prettyPrint nms -- there might be more that one Haskell field name ("a,b::Int")
fLabel = mkLabel fs -- produce proper DOT description of the type
in case fs of
-- If it is a simple one-component type, just add a record name and be done with it
[f] -> f { fieldName=(Just $ name fName) }
-- If it is multi-component type, ...
_ -> F { fieldName=(Just $ name fName) -- add record name, ...
, fieldPort=Nothing
, typeName=fLabel -- save type description
, fieldLink = (concatMap fieldLink fs) -- collect all links from all type components
}
-- DOT record node construction helper
record label = node $ [ ("shape","record"),("label",block label) ]
-- Record label construnction helpers
infix <||>, <//>
a <||> b = concat [a, " | ", b]
a <//> b = concat [ a, " | { ", b, " }"]
block x = "{ " ++ x ++ " }"
-- Haskell AST manipulation helpers
findDecl nm decls = find ((==nm).getName) decls
getName (DataDecl _ _ _ nm _ _ _) = fromName nm
getName (TypeDecl _ nm _ _) = fromName nm
getDeclType (DataDecl _ DataType _ _ _ _ _) = "data"
getDeclType (DataDecl _ NewType _ _ _ _ _) = "newtype"
getDeclType (TypeDecl _ _ _ _) = "type"
fromName (Ident x) = x
fromName (Symbol x) = x
names ns = concat $ intersperse ", " $ map fromName ns