a3/code/Gast/iDataGraphvizForm.icl

   1 implementation module iDataGraphvizForm
   2
   3 import StdEnv
   4 import StdiData, iDataHandler
   5 import Graphviz
   6 import launch
   7 import Directory
   8
   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
  39
  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)
  43 where
  44         nodeNr                          = case [nr \\ NodeDef nr _ nodeAtts _ <- nodeDefs | not (isEmpty (filter (isNAtt_label node) nodeAtts))] of
  45                                                         [nr:_]  = Just (Node nr)
  46                                                         _               = Nothing
  47         isNAtt_label l (NAtt_label l`)
  48                                                 = l==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)
  55
  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)
  76                                                                 ]
  77                                                           : map InlineCode lines
  78                                                           ],incrHSt 1 hst)
  79 where
  80         digraph                         = formid.ival
  81         name                            = formid.id
  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
  86
  87
  88         clean_up :: !String -> String
  89 //      clean_up name           = name
  90         clean_up name           = {clean_char c \\ c<-: name}
  91         clean_char '.'          = 'x'
  92         clean_char '+'          = 'p'
  93         clean_char '-'          = 'm'
  94         clean_char c            = c
  95
  96         enhanceMAPlineWithOnClickEvent :: !Int !String -> String
  97         enhanceMAPlineWithOnClickEvent cntr line
  98                 | line%(0,5) == "<area "
  99                         | size line <= 6 || isNothing href_bounds //|| isNothing title_bounds
 100                                                 = line
 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"
 107                 | otherwise
 108                                                 = line
 109         where
 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)
 115
 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)
 121                                                         otherwise       = Nothing
 122                 otherwise               = Nothing
 123
 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
 129                 ] selected
 130
 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)
 139 where
 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
 147                                                        ] of [v:_]       = Just v
 148                                                             _           = Nothing
 149                 = (value,file)
 150         where
 151                 name_length             = size name
 152
 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"
 163
 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.
 168 */
 169 import StdDebug
 170
 171 ensureDirectory :: !String !*env -> *env | FileSystem env       // PA++
 172 ensureDirectory pathname env
 173         # ((ok,path), env)      = pd_StringToPath pathname env
 174         | not ok                        = env
 175         # ((err,info),env)      = getFileInfo path env
 176         | err<>NoDirError       = snd (createDirectory path env)
 177         | otherwise                     = env
 178
 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
 184         = fclose file env
 185
 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
 192         = (ok,content,env)
 193
 194 readlines :: !*File -> (![String],!*File)
 195 readlines file
 196         # (end,file)            = fend file
 197         | end                           = ([],file)
 198         # (line, file)          = freadline file
 199         # (lines,file)          = readlines file
 200         = ([line:lines],file)
 201
 202 collect3 :: (.s -> (.a,.b,.s)) .s -> (.(.a,.b),.s)
 203 collect3 f st
 204         # (a,b,st)                      = f st
 205         = ((a,b),st)
 206
 207 skipSpace :: !String -> String
 208 skipSpace str                   = toString (dropWhile isSpace (fromString str))