--- /dev/null
+implementation module iDataGraphvizForm\r
+\r
+import StdEnv\r
+import StdiData, iDataHandler\r
+import Graphviz\r
+import launch\r
+import Directory\r
+\r
+derive gUpd [], Maybe, NodeState, //Digraph, \r
+ Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint, \r
+ EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin, \r
+ NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf, \r
+ RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort\r
+derive gPrint Maybe, Digraph, NodeState,\r
+ Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint, \r
+ EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin, \r
+ NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf, \r
+ RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort\r
+derive gParse Maybe, Digraph, NodeState,\r
+ Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint, \r
+ EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin, \r
+ NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf, \r
+ RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort\r
+derive gerda Digraph, NodeState, \r
+ Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint, \r
+ EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin, \r
+ NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf, \r
+ RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort\r
+derive read Maybe, Digraph, NodeState, \r
+ Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint, \r
+ EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin, \r
+ NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf, \r
+ RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort\r
+derive write Maybe, Digraph, NodeState, \r
+ Arrow, ArrowShape, ArrowType, ClusterMode, Color, CompassPoint, DirType, DotPoint, \r
+ EdgeAttribute, EdgeStyle, GraphAttribute, LayerId, LayerList, LayerRange, Margin, \r
+ NodeAttribute, NodeDef, NodeShape, NodeStyle, OutputMode, Pad, PageDir, Pointf, \r
+ RankDir, RankType, Ratio, Rect, SelectedItem, Side, Sizef, StartStyle, StartType, ViewPort\r
+\r
+// Specialization of iData for Digraph values:\r
+gUpd {|Digraph|} (UpdSearch (UpdC node) 0) (Digraph name graphAtts nodeDefs _)\r
+ = (UpdDone, Digraph name graphAtts nodeDefs nodeNr)\r
+where\r
+ nodeNr = case [nr \\ NodeDef nr _ nodeAtts _ <- nodeDefs | not (isEmpty (filter (isNAtt_label node) nodeAtts))] of\r
+ [nr:_] = Just (Node nr)\r
+ _ = Nothing\r
+ isNAtt_label l (NAtt_label l`)\r
+ = l==l`\r
+ isNAtt_label _ _ = False\r
+gUpd {|Digraph|} (UpdSearch other cnt) g\r
+ = (UpdSearch other (cnt-1),g)\r
+gUpd {|Digraph|} (UpdCreate l) _\r
+ = (UpdCreate l,Digraph "" [] [] Nothing)\r
+gUpd {|Digraph|} mode g = (mode,g)\r
+\r
+gForm {|Digraph|} (init,formid) hst\r
+ # (value,hst) = accWorldHSt (obtainValueFromConfig dot_exe_path_name) hst\r
+ | isNothing value = (result [ Txt ("Could not obtain "+++dot_exe_path_name+++" from "+++config_file_name+++".") ],hst)\r
+ # exe = fromJust value\r
+ # hst = appWorldHSt (ensureDirectory (target "")) hst // PA++\r
+ # (ok,hst) = accWorldHSt (writefile (target (dotext name)) (printDigraph (enhanceDigraphWithLinks digraph))) hst\r
+ | not ok = (result [ Txt ("Could not write Digraph to "+++target (dotext name)+++".") ],hst)\r
+ # ((ok,exit),hst) = accWorldHSt (collect3 (launch exe (toGIF (target name)))) hst\r
+ | not ok = (result [ Txt ("Creation of "+++gifext (target name)+++" failed. Exit code = "+++toString exit+++".") ],hst)\r
+ # ((ok,exit),hst) = accWorldHSt (collect3 (launch exe (toMAP (target name) name))) hst\r
+ | not ok = (result [ Txt ("Creation of "+++mapext (target name)+++" failed. Exit code = "+++toString exit+++".") ],hst)\r
+ # ((ok,lines),hst) = accWorldHSt (collect3 (readfile (mapext map_source_name))) hst\r
+ | not ok = (result [ Txt ("Reading of "+++mapext (target name)+++" failed.") ],hst)\r
+ # (cntr,hst) = CntrHSt hst\r
+ # lines = map (enhanceMAPlineWithOnClickEvent cntr) lines\r
+ | otherwise = (result [ \r
+ Img [ Img_Src (gifext img_source_name)\r
+ , Img_Usemap ("#"+++name)\r
+// , Img_Width (Percent 100)\r
+ , Img_Height (Percent 60)\r
+ ]\r
+ : map InlineCode lines\r
+ ],incrHSt 1 hst)\r
+where\r
+ digraph = formid.ival\r
+ name = formid.id\r
+ clean_name = clean_up name\r
+ result html = {changed=False,value=digraph,form=html}\r
+ img_source_name = ThisExe+++"/"+++name\r
+ map_source_name = ThisExe+++"/"+++name\r
+\r
+ \r
+ clean_up :: !String -> String\r
+// clean_up name = name\r
+ clean_up name = {clean_char c \\ c<-: name}\r
+ clean_char '.' = 'x'\r
+ clean_char '+' = 'p'\r
+ clean_char '-' = 'm'\r
+ clean_char c = c\r
+\r
+ enhanceMAPlineWithOnClickEvent :: !Int !String -> String\r
+ enhanceMAPlineWithOnClickEvent cntr line\r
+ | line%(0,5) == "<area "\r
+ | size line <= 6 || isNothing href_bounds //|| isNothing title_bounds\r
+ = line\r
+ | otherwise = line%(0,fst href-1) +++ \r
+ "onclick=\"toClean(this,'" +++ encodeTriplet(name,cntr,UpdC titletext) +++ "',true,false,false);\" " +++ \r
+ "id=\""+++ encodeInputId(name,cntr,UpdC titletext) +++ "\"" +++\r
+ line%(snd href+1,size line-1)\r
+ | line%(0,4) == "<map "\r
+ = "<map id=\"" +++ name +++ "\" name=\"" +++ name +++ "\">\n"\r
+ | otherwise\r
+ = line\r
+ where\r
+ href_bounds = boundsOfKeyValue "href=" line\r
+ title_bounds = boundsOfKeyValue "title=" line\r
+ href = fromJust href_bounds\r
+ title = fromJust title_bounds\r
+ titletext = line%(fst title+7,snd title-1)\r
+\r
+boundsOfKeyValue :: !String !String -> Maybe (!Int,!Int)\r
+boundsOfKeyValue key str\r
+ = case [i \\ i<-[0..size str-size key] | str%(i,i+size key-1) == key] of\r
+ [i : _] = case [j \\ j<-[i..size str-1] | str.[j]=='\"'] of\r
+ [_,close:_] = Just (i,close)\r
+ otherwise = Nothing\r
+ otherwise = Nothing\r
+\r
+enhanceDigraphWithLinks :: !Digraph -> Digraph\r
+enhanceDigraphWithLinks (Digraph name graphAtts nodeDefs selected)\r
+ = Digraph name graphAtts \r
+ [ NodeDef nr st [ NAtt_URL ("http://localhost/"+++ThisExe) : nodeAtts ] edges \r
+ \\ NodeDef nr st nodeAtts edges <- nodeDefs\r
+ ] selected\r
+\r
+obtainValueFromConfig :: !String !*env -> (!Maybe String,!*env) | FileSystem env\r
+obtainValueFromConfig name env\r
+ # (ok,file,env) = fopen config_file_name FReadText env\r
+ | not ok = (Nothing,env)\r
+ # (value,file) = obtainValueFromFile name file\r
+ # (ok,env) = fclose file env\r
+ | not ok = (Nothing,env)\r
+ | otherwise = (value, env)\r
+where\r
+ obtainValueFromFile :: !String !*File -> (!Maybe String,!*File)\r
+ obtainValueFromFile name file\r
+ # (lines,file) = readlines file\r
+ # value = case [ skipSpace (line%(name_length,size line-2)) \\ line<-lines\r
+ | line.[0] <> commentsymbol \r
+ && size line > name_length\r
+ && line%(0,name_length-1) == name\r
+ ] of [v:_] = Just v\r
+ _ = Nothing\r
+ = (value,file)\r
+ where\r
+ name_length = size name\r
+\r
+config_file_name :== "iDataGraphvizForm.config"\r
+commentsymbol :== '%'\r
+dot_exe_path_name :== "DOT_PATH"\r
+target file = MyAbsDir +++ ThisExe +++ "\\" +++ file\r
+toGIF file = "-Tgif -o " +++ "\"" +++ gifext file +++ "\" \"" +++ dotext file +++ "\""\r
+//toMAP file = "-Tcmapx -o " +++ "\"" +++ mapext file +++ "\" \"" +++ dotext file +++ "\""\r
+toMAP file name = "-Tcmapx" +++ " -Glabel=" +++ name +++ " -o " +++ "\"" +++ mapext file +++ "\" \"" +++ dotext file +++ "\""\r
+gifext file = file +++ ".gif"\r
+mapext file = file +++ ".map"\r
+dotext file = file +++ ".dot"\r
+\r
+// Utility functions:\r
+/* ensureDirectory path env\r
+ checks whether the directory at path exists. If so, no further actions are taken.\r
+ If not, the directory is created.\r
+*/\r
+import StdDebug\r
+\r
+ensureDirectory :: !String !*env -> *env | FileSystem env // PA++\r
+ensureDirectory pathname env\r
+ # ((ok,path), env) = pd_StringToPath pathname env\r
+ | not ok = env\r
+ # ((err,info),env) = getFileInfo path env\r
+ | err<>NoDirError = snd (createDirectory path env)\r
+ | otherwise = env\r
+\r
+writefile :: !String ![String] !*env -> (!Bool,!*env) | FileSystem env\r
+writefile fileName content env\r
+ # (ok,file,env) = fopen fileName FWriteText env\r
+ | not ok = (False,env)\r
+ # file = foldl (<<<) file content\r
+ = fclose file env\r
+\r
+readfile :: !String !*env -> (!Bool,![String],!*env) | FileSystem env\r
+readfile fileName env\r
+ # (ok,file,env) = fopen fileName FReadText env\r
+ | not ok = (False,[],env)\r
+ # (content,file) = readlines file\r
+ # (ok,env) = fclose file env\r
+ = (ok,content,env)\r
+\r
+readlines :: !*File -> (![String],!*File)\r
+readlines file\r
+ # (end,file) = fend file\r
+ | end = ([],file)\r
+ # (line, file) = freadline file\r
+ # (lines,file) = readlines file\r
+ = ([line:lines],file)\r
+\r
+collect3 :: (.s -> (.a,.b,.s)) .s -> (.(.a,.b),.s)\r
+collect3 f st\r
+ # (a,b,st) = f st\r
+ = ((a,b),st)\r
+\r
+skipSpace :: !String -> String\r
+skipSpace str = toString (dropWhile isSpace (fromString str))\r
repositories / tt2015.git / blobdiff