1 implementation module iDataGraphvizForm
4 import StdiData, iDataHandler
9 derive gUpd [], Maybe, NodeState, //Digraph,
10 Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint,
11 EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin,
12 NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf,
13 RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort
14 derive gPrint Maybe, Digraph, NodeState,
15 Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint,
16 EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin,
17 NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf,
18 RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort
19 derive gParse Maybe, Digraph, NodeState,
20 Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint,
21 EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin,
22 NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf,
23 RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort
24 derive gerda Digraph, NodeState,
25 Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint,
26 EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin,
27 NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf,
28 RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort
29 derive read Maybe, Digraph, NodeState,
30 Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint,
31 EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin,
32 NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf,
33 RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort
34 derive write Maybe, Digraph, NodeState,
35 Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint,
36 EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin,
37 NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf,
38 RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort
40 // Specialization of iData for Digraph values:
41 gUpd {|Digraph|} (UpdSearch (UpdC node) 0) (Digraph name graphAtts nodeDefs _)
42 = (UpdDone, Digraph name graphAtts nodeDefs nodeNr)
44 nodeNr = case [nr \\ NodeDef nr _ nodeAtts _ <- nodeDefs | not (isEmpty (filter (isNAtt_label node) nodeAtts))] of
45 [nr:_] = Just (Node nr)
47 isNAtt_label l (NAtt_label l`)
49 isNAtt_label _ _ = False
50 gUpd {|Digraph|} (UpdSearch other cnt) g
51 = (UpdSearch other (cnt-1),g)
52 gUpd {|Digraph|} (UpdCreate l) _
53 = (UpdCreate l,Digraph "" [] [] Nothing)
54 gUpd {|Digraph|} mode g = (mode,g)
56 gForm {|Digraph|} (init,formid) hst
57 # (value,hst) = accWorldHSt (obtainValueFromConfig dot_exe_path_name) hst
58 | isNothing value = (result [ Txt ("Could not obtain "+++dot_exe_path_name+++" from "+++config_file_name+++".") ],hst)
59 # exe = fromJust value
60 # hst = appWorldHSt (ensureDirectory (target "")) hst // PA++
61 # (ok,hst) = accWorldHSt (writefile (target (dotext name)) (printDigraph (enhanceDigraphWithLinks digraph))) hst
62 | not ok = (result [ Txt ("Could not write Digraph to "+++target (dotext name)+++".") ],hst)
63 # ((ok,exit),hst) = accWorldHSt (collect3 (launch exe (toGIF (target name)))) hst
64 | not ok = (result [ Txt ("Creation of "+++gifext (target name)+++" failed. Exit code = "+++toString exit+++".") ],hst)
65 # ((ok,exit),hst) = accWorldHSt (collect3 (launch exe (toMAP (target name) name))) hst
66 | not ok = (result [ Txt ("Creation of "+++mapext (target name)+++" failed. Exit code = "+++toString exit+++".") ],hst)
67 # ((ok,lines),hst) = accWorldHSt (collect3 (readfile (mapext map_source_name))) hst
68 | not ok = (result [ Txt ("Reading of "+++mapext (target name)+++" failed.") ],hst)
69 # (cntr,hst) = CntrHSt hst
70 # lines = map (enhanceMAPlineWithOnClickEvent cntr) lines
71 | otherwise = (result [
72 Img [ Img_Src (gifext img_source_name)
73 , Img_Usemap ("#"+++name)
74 // , Img_Width (Percent 100)
75 , Img_Height (Percent 60)
77 : map InlineCode lines
82 clean_name = clean_up name
83 result html = {changed=False,value=digraph,form=html}
84 img_source_name = ThisExe+++"/"+++name
85 map_source_name = ThisExe+++"/"+++name
88 clean_up :: !String -> String
89 // clean_up name = name
90 clean_up name = {clean_char c \\ c<-: name}
96 enhanceMAPlineWithOnClickEvent :: !Int !String -> String
97 enhanceMAPlineWithOnClickEvent cntr line
98 | line%(0,5) == "<area "
99 | size line <= 6 || isNothing href_bounds //|| isNothing title_bounds
101 | otherwise = line%(0,fst href-1) +++
102 "onclick=\"toClean(this,'" +++ encodeTriplet(name,cntr,UpdC titletext) +++ "',true,false,false);\" " +++
103 "id=\""+++ encodeInputId(name,cntr,UpdC titletext) +++ "\"" +++
104 line%(snd href+1,size line-1)
105 | line%(0,4) == "<map "
106 = "<map id=\"" +++ name +++ "\" name=\"" +++ name +++ "\">\n"
110 href_bounds = boundsOfKeyValue "href=" line
111 title_bounds = boundsOfKeyValue "title=" line
112 href = fromJust href_bounds
113 title = fromJust title_bounds
114 titletext = line%(fst title+7,snd title-1)
116 boundsOfKeyValue :: !String !String -> Maybe (!Int,!Int)
117 boundsOfKeyValue key str
118 = case [i \\ i<-[0..size str-size key] | str%(i,i+size key-1) == key] of
119 [i : _] = case [j \\ j<-[i..size str-1] | str.[j]=='\"'] of
120 [_,close:_] = Just (i,close)
124 enhanceDigraphWithLinks :: !Digraph -> Digraph
125 enhanceDigraphWithLinks (Digraph name graphAtts nodeDefs selected)
126 = Digraph name graphAtts
127 [ NodeDef nr st [ NAtt_URL ("http://localhost/"+++ThisExe) : nodeAtts ] edges
128 \\ NodeDef nr st nodeAtts edges <- nodeDefs
131 obtainValueFromConfig :: !String !*env -> (!Maybe String,!*env) | FileSystem env
132 obtainValueFromConfig name env
133 # (ok,file,env) = fopen config_file_name FReadText env
134 | not ok = (Nothing,env)
135 # (value,file) = obtainValueFromFile name file
136 # (ok,env) = fclose file env
137 | not ok = (Nothing,env)
138 | otherwise = (value, env)
140 obtainValueFromFile :: !String !*File -> (!Maybe String,!*File)
141 obtainValueFromFile name file
142 # (lines,file) = readlines file
143 # value = case [ skipSpace (line%(name_length,size line-2)) \\ line<-lines
144 | line.[0] <> commentsymbol
145 && size line > name_length
146 && line%(0,name_length-1) == name
151 name_length = size name
153 config_file_name :== "iDataGraphvizForm.config"
154 commentsymbol :== '%'
155 dot_exe_path_name :== "DOT_PATH"
156 target file = MyAbsDir +++ ThisExe +++ "\\" +++ file
157 toGIF file = "-Tgif -o " +++ "\"" +++ gifext file +++ "\" \"" +++ dotext file +++ "\""
158 //toMAP file = "-Tcmapx -o " +++ "\"" +++ mapext file +++ "\" \"" +++ dotext file +++ "\""
159 toMAP file name = "-Tcmapx" +++ " -Glabel=" +++ name +++ " -o " +++ "\"" +++ mapext file +++ "\" \"" +++ dotext file +++ "\""
160 gifext file = file +++ ".gif"
161 mapext file = file +++ ".map"
162 dotext file = file +++ ".dot"
164 // Utility functions:
165 /* ensureDirectory path env
166 checks whether the directory at path exists. If so, no further actions are taken.
167 If not, the directory is created.
171 ensureDirectory :: !String !*env -> *env | FileSystem env // PA++
172 ensureDirectory pathname env
173 # ((ok,path), env) = pd_StringToPath pathname env
175 # ((err,info),env) = getFileInfo path env
176 | err<>NoDirError = snd (createDirectory path env)
179 writefile :: !String ![String] !*env -> (!Bool,!*env) | FileSystem env
180 writefile fileName content env
181 # (ok,file,env) = fopen fileName FWriteText env
182 | not ok = (False,env)
183 # file = foldl (<<<) file content
186 readfile :: !String !*env -> (!Bool,![String],!*env) | FileSystem env
187 readfile fileName env
188 # (ok,file,env) = fopen fileName FReadText env
189 | not ok = (False,[],env)
190 # (content,file) = readlines file
191 # (ok,env) = fclose file env
194 readlines :: !*File -> (![String],!*File)
196 # (end,file) = fend file
198 # (line, file) = freadline file
199 # (lines,file) = readlines file
200 = ([line:lines],file)
202 collect3 :: (.s -> (.a,.b,.s)) .s -> (.(.a,.b),.s)
207 skipSpace :: !String -> String
208 skipSpace str = toString (dropWhile isSpace (fromString str))