extra/graphviz/render/render.factor

   1 ! Copyright (C) 2012 Alex Vondrak.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: calendar combinators compiler.units continuations
   4 graphviz.dot images.viewer io.backend io.directories
   5 io.encodings.8-bit.latin1 io.encodings.utf8 io.files
   6 io.files.unique io.launcher io.standard-paths kernel locals make
   7 namespaces sequences summary system threads unicode.case vocabs
   8 webbrowser words ;
   9 IN: graphviz.render
  10
  11 <PRIVATE
  12
  13 ! "Layout Commands" from http://graphviz.org/Documentation.php
  14 CONSTANT: standard-layouts {
  15     "circo"
  16     "dot"
  17     "fdp"
  18     "neato"
  19     "osage"
  20     "sfdp"
  21     "twopi"
  22 }
  23
  24 PRIVATE>
  25
  26 SYMBOL: default-layout
  27 "dot" default-layout set-global
  28
  29 SYMBOL: preview-format
  30 "png" preview-format set-global
  31
  32 ERROR: unsupported-preview-format preview-format ;
  33
  34 M: unsupported-preview-format summary
  35     drop "Unsupported preview format" ;
  36
  37 SYMBOL: graph-encoding
  38 utf8 graph-encoding set-global
  39
  40 ERROR: unsupported-encoding graph-encoding ;
  41
  42 M: unsupported-encoding summary
  43     drop "Must use utf8 or latin1 (match the graph's charset attribute)" ;
  44
  45 HOOK: default-graphviz-program os ( -- path/f )
  46
  47 M: object default-graphviz-program ( -- path/f )
  48     standard-layouts [ find-in-standard-login-path ] map-find drop ;
  49
  50 ERROR: cannot-find-graphviz-installation ;
  51
  52 M: cannot-find-graphviz-installation summary
  53     drop "Cannot find Graphviz installation" ;
  54
  55 : ?default-graphviz-program ( -- path )
  56     default-graphviz-program
  57     [ cannot-find-graphviz-installation ] unless* ;
  58
  59 <PRIVATE
  60
  61 : try-graphviz-command ( path format layout -- )
  62     [
  63         ?default-graphviz-program ,
  64         [ , "-O" , ]
  65         [ "-T" , , ]
  66         [ "-K" , , ] tri*
  67     ] { } make try-output-process ;
  68
  69 : ?encoding ( -- encoding )
  70     graph-encoding get-global
  71     dup [ utf8? ] [ latin1? ] bi or
  72     [ unsupported-encoding ] unless ;
  73
  74 : ?delete-file ( path -- )
  75     dup exists? [ delete-file ] [ drop ] if ;
  76
  77 PRIVATE>
  78
  79 :: graphviz ( graph path format layout -- )
  80     path normalize-path :> dot-file
  81     [
  82         graph dot-file ?encoding write-dot
  83         dot-file format layout try-graphviz-command
  84     ]
  85     [ dot-file ?delete-file ] [ ] cleanup ;
  86
  87 : graphviz* ( graph path format -- )
  88     default-layout get-global graphviz ;
  89
  90 <PRIVATE
  91
  92 : try-preview-command ( from-path to-path -- )
  93     [
  94         ?default-graphviz-program ,
  95         [ , ]
  96         [ "-o" , , ] bi*
  97         "-T" , preview-format get-global ,
  98         "-K" , default-layout get-global ,
  99     ] { } make try-output-process ;
 100
 101 ! Not only must Graphviz support the image format, but so must
 102 ! images.loader
 103
 104 : preview-extension ( -- extension )
 105     preview-format get-global >lower {
 106         { "bmp"  [ ".bmp" ] }
 107         { "gif"  [ ".gif" ] }
 108         { "ico"  [ ".ico" ] }
 109         { "jpg"  [ ".jpg" ] }
 110         { "jpeg" [ ".jpg" ] }
 111         { "jpe"  [ ".jpg" ] }
 112         { "png"  [ ".png" ] }
 113         { "tif"  [ ".tif" ] }
 114         { "tiff" [ ".tif" ] }
 115         [ unsupported-preview-format ]
 116     } case ;
 117
 118 :: with-preview ( graph quot: ( path -- ) -- )
 119     "preview" ".dot" [| code-file |
 120         "preview" preview-extension [| image-file |
 121             graph code-file ?encoding write-dot
 122             code-file image-file try-preview-command
 123             image-file quot call( path -- )
 124         ] cleanup-unique-file
 125     ] cleanup-unique-file ;
 126
 127 PRIVATE>
 128
 129 : preview ( graph -- )
 130     [ image. ] with-preview ;
 131
 132 : preview-window ( graph -- )
 133     [ image-window ] with-preview ;
 134
 135 : preview-open ( graph -- )
 136     [ open-file 1 seconds sleep ] with-preview ;
 137
 138 <PRIVATE
 139
 140 ! http://graphviz.org/content/output-formats
 141 CONSTANT: standard-formats {
 142     "bmp"
 143     "canon"
 144     "dot"
 145     "xdot"
 146     "cmap"
 147     "eps"
 148     "fig"
 149     "gd"
 150     "gd2"
 151     "gif"
 152     "ico"
 153     "imap"
 154     "cmapx"
 155     "imap_np"
 156     "cmapx_np"
 157     "ismap"
 158     "jpg"
 159     "jpeg"
 160     "jpe"
 161     "pdf"
 162     "plain"
 163     "plain-ext"
 164     "png"
 165     "ps"
 166     "ps2"
 167     "svg"
 168     "svgz"
 169     "tif"
 170     "tiff"
 171     "vml"
 172     "vmlz"
 173     "vrml"
 174     "wbmp"
 175     "webp"
 176     ! ! ! Canvas formats don't actually use path argument...
 177     ! "gtk"
 178     ! "xlib"
 179 }
 180
 181 : define-graphviz-by-layout ( layout -- )
 182     [ "graphviz.render" create-word ]
 183     [ [ graphviz ] curry ] bi
 184     ( graph path format -- )
 185     define-declared ;
 186
 187 : define-graphviz-by-format ( format -- )
 188     [
 189         dup standard-layouts member? [ "-file" append ] when
 190         "graphviz.render" create-word
 191     ]
 192     [ [ graphviz* ] curry ] bi
 193     ( graph path -- )
 194     define-declared ;
 195
 196 PRIVATE>
 197
 198 [
 199     standard-layouts [ define-graphviz-by-layout ] each
 200     standard-formats [ define-graphviz-by-format ] each
 201 ] with-compilation-unit
 202
 203 os windows? [ "graphviz.render.windows" require ] when