basis/gobject-introspection/loader/loader.factor

   1 ! Copyright (C) 2010 Anton Gorenko.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors ascii combinators gobject-introspection.common
   4 gobject-introspection.repository kernel literals math.parser
   5 sequences splitting xml.data xml.traversal ;
   6 IN: gobject-introspection.loader
   7
   8 : xml>simple-type ( xml -- type )
   9     [ simple-type new ] dip {
  10         [ "name" attr >>name ]
  11         [
  12             "type" tags-named
  13             [ xml>simple-type ] map f like >>element-types
  14         ]
  15     } cleave ;
  16
  17 : xml>varargs-type ( xml -- type )
  18     drop varargs-type new ;
  19
  20 : xml>array-type ( xml -- type )
  21     [ array-type new ] dip {
  22         [ "name" attr >>name ]
  23         [ "zero-terminated" attr "0" = not >>zero-terminated? ]
  24         [ "length" attr string>number >>length ]
  25         [ "fixed-size" attr string>number >>fixed-size ]
  26         [ "type" tag-named xml>simple-type >>element-type ]
  27     } cleave ;
  28
  29 : xml>inner-callback-type ( xml -- type )
  30     [ inner-callback-type new ] dip {
  31         [ "name" attr >>name ]
  32     } cleave ;
  33
  34 : xml>type ( xml -- type )
  35     dup name>> main>> {
  36         { "type" [ xml>simple-type ] }
  37         { "array"[ xml>array-type ] }
  38         { "callback" [ xml>inner-callback-type ] }
  39         { "varargs" [ xml>varargs-type ] }
  40     } case ;
  41
  42 CONSTANT: type-tags
  43     $[ { "array" "type" "callback" "varargs" } [ <null-name> ] map ]
  44
  45 : child-type-tag ( xml -- type-tag )
  46     children-tags [
  47         type-tags [ swap tag-named? ] with any?
  48     ] find nip ;
  49
  50 : xml>alias ( xml -- alias )
  51     [ alias new ] dip {
  52         [ "name" attr >>name ]
  53         [ "type" attr >>c-type ]
  54         [ child-type-tag xml>type >>type ]
  55     } cleave ;
  56
  57 : xml>const ( xml -- const )
  58     [ const new ] dip {
  59         [ "name" attr >>name ]
  60         [ "value" attr >>value ]
  61         [ child-type-tag xml>type >>type ]
  62     } cleave ;
  63
  64 : load-type ( type xml -- type )
  65     {
  66         [ "name" attr >>name ]
  67         [ [ "type" attr ] [ "type-name" attr ] bi or >>c-type ]
  68         [ "get-type" attr >>get-type ]
  69     } cleave ;
  70
  71 : xml>member ( xml -- member )
  72     [ enum-member new ] dip {
  73         [ "name" attr >>name ]
  74         [ "identifier" attr >>c-identifier ]
  75         [ "value" attr string>number >>value ]
  76     } cleave ;
  77
  78 : xml>enum ( xml -- enum )
  79     [ enum new ] dip {
  80         [ load-type ]
  81         [ "member" tags-named [ xml>member ] map >>members ]
  82     } cleave ;
  83
  84 : load-parameter ( param xml -- param )
  85     [ child-type-tag xml>type >>type ]
  86     [ "transfer-ownership" attr >>transfer-ownership ] bi ;
  87
  88 : xml>parameter ( xml -- parameter )
  89     [ parameter new ] dip {
  90         [ "name" attr >>name ]
  91         [ "direction" attr dup "in" ? >>direction ]
  92         [ "allow-none" attr "1" = >>allow-none? ]
  93         [ child-type-tag xml>type >>type ]
  94         [ "transfer-ownership" attr >>transfer-ownership ]
  95     } cleave ;
  96
  97 : xml>return ( xml -- return )
  98     [ return new ] dip {
  99         [ child-type-tag xml>type >>type ]
 100         [ "transfer-ownership" attr >>transfer-ownership ]
 101     } cleave ;
 102
 103 : load-callable ( callable xml -- callable )
 104     [ "return-value" tag-named xml>return >>return ]
 105     [
 106         "parameters" tag-named "parameter" tags-named
 107         [ xml>parameter ] map >>parameters
 108     ] bi ;
 109
 110 : xml>function ( xml -- function )
 111     [ function new ] dip {
 112         [ "name" attr >>name ]
 113         [ "identifier" attr >>identifier ]
 114         [ load-callable ]
 115         [ "throws" attr "1" = >>throws? ]
 116     } cleave ;
 117
 118 : load-functions ( xml tag-name -- functions )
 119     tags-named [ xml>function ] map ;
 120
 121 : xml>field ( xml -- field )
 122     [ field new ] dip {
 123         [ "name" attr >>name ]
 124         [ "writable" attr "1" = >>writable? ]
 125         [ "bits" attr string>number >>bits ]
 126         [ child-type-tag xml>type >>type ]
 127     } cleave ;
 128
 129 : xml>record ( xml -- record )
 130     [ record new ] dip {
 131         [ load-type ]
 132         [
 133             over c-type>> implement-struct?
 134             [ "field" tags-named [ xml>field ] map >>fields ]
 135             [ drop ] if
 136         ]
 137         [ "constructor" load-functions >>constructors ]
 138         [ "method" load-functions >>methods ]
 139         [ "function" load-functions >>functions ]
 140         [ "disguised" attr "1" = >>disguised? ]
 141         [ "is-gtype-struct-for" attr >>struct-for ]
 142     } cleave ;
 143
 144 : xml>union ( xml -- union )
 145     [ union new ] dip {
 146         [ load-type ]
 147         [ "field" tags-named [ xml>field ] map >>fields ]
 148         [ "constructor" load-functions >>constructors ]
 149         [ "method" load-functions >>methods ]
 150         [ "function" load-functions >>functions ]
 151     } cleave ;
 152
 153 : xml>callback ( xml -- callback )
 154     [ callback new ] dip {
 155         [ load-type ]
 156         [ load-callable ]
 157         [ "throws" attr "1" = >>throws? ]
 158     } cleave ;
 159
 160 : xml>signal ( xml -- signal )
 161     [ signal new ] dip {
 162         [ "name" attr >>name ]
 163         [ load-callable ]
 164     } cleave ;
 165
 166 : xml>property ( xml -- property )
 167     [ property new ] dip {
 168         [ "name" attr >>name ]
 169         [ "writable" attr "1" = >>writable? ]
 170         [ "readable" attr "0" = not >>readable? ]
 171         [ "construct" attr "1" = >>construct? ]
 172         [ "construct-only" attr "1" = >>construct-only? ]
 173         [ child-type-tag xml>type >>type ]
 174     } cleave ;
 175
 176 : xml>class ( xml -- class )
 177     [ class new ] dip {
 178         [ load-type ]
 179         [ "abstract" attr "1" = >>abstract? ]
 180         [ "parent" attr >>parent ]
 181         [ "type-struct" attr >>type-struct ]
 182         [ "constructor" load-functions >>constructors ]
 183         [ "method" load-functions >>methods ]
 184         [ "function" load-functions >>functions ]
 185         [ "signal" tags-named [ xml>signal ] map >>signals ]
 186     } cleave ;
 187
 188 : xml>interface ( xml -- interface )
 189     [ interface new ] dip {
 190         [ load-type ]
 191         [ "method" load-functions >>methods ]
 192         [ "function" load-functions >>functions ]
 193         [ "signal" tags-named [ xml>signal ] map >>signals ]
 194     } cleave ;
 195
 196 : xml>boxed ( xml -- boxed )
 197     [ boxed new ] dip
 198         load-type ;
 199
 200 : fix-conts ( namespace -- )
 201     [ symbol-prefixes>> first >upper "_" append ] [ consts>> ] bi
 202     [ [ name>> append ] keep c-identifier<< ] with each ;
 203
 204 : postprocess-namespace ( namespace -- )
 205     fix-conts ;
 206
 207 : xml>namespace ( xml -- namespace )
 208     [ namespace new ] dip {
 209         [ "name" attr >>name ]
 210         [ "identifier-prefixes" attr "," split >>identifier-prefixes ]
 211         [ "symbol-prefixes" attr "," split >>symbol-prefixes ]
 212         [ "alias" tags-named [ xml>alias ] map >>aliases ]
 213         [ "constant" tags-named [ xml>const ] map >>consts ]
 214         [ "enumeration" tags-named [ xml>enum ] map >>enums ]
 215         [ "bitfield" tags-named [ xml>enum ] map >>bitfields ]
 216         [ "record" tags-named [ xml>record ] map >>records ]
 217         [ "union" tags-named [ xml>union ] map >>unions ]
 218         [ "boxed" tags-named [ xml>boxed ] map >>boxeds ]
 219         [ "callback" tags-named [ xml>callback ] map >>callbacks ]
 220         [ "class" tags-named [ xml>class ] map >>classes ]
 221         [ "interface" tags-named [ xml>interface ] map >>interfaces ]
 222         [ "function" load-functions >>functions ]
 223     } cleave [ postprocess-namespace ] keep ;
 224
 225 : xml>repository ( xml -- repository )
 226     [ repository new ] dip
 227     "namespace" tag-named xml>namespace >>namespace ;