basis/alien/enums/enums.factor

   1 ! Copyright (C) 2010 Joe Groff, Erik Charlebois.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types arrays assocs classes.singleton
   4 combinators delegate kernel math parser sequences words ;
   5 IN: alien.enums
   6
   7 <PRIVATE
   8 TUPLE: enum-c-type base-type members ;
   9 C: <enum-c-type> enum-c-type
  10 CONSULT: c-type-protocol enum-c-type
  11     base-type>> ;
  12 PRIVATE>
  13
  14 GENERIC: enum>number ( enum -- number ) foldable
  15 M: integer enum>number ;
  16 M: word enum>number "enum-value" word-prop ;
  17
  18 <PRIVATE
  19 : enum-boxer ( members -- quot )
  20     [ first2 swap '[ _ ] 2array ]
  21     { } map-as [ ] suffix '[ _ case ] ;
  22 PRIVATE>
  23
  24 MACRO: number>enum ( enum-c-type -- quot )
  25     lookup-c-type members>> enum-boxer ;
  26
  27 M: enum-c-type c-type-boxed-class drop object ;
  28 M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
  29 M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
  30 M: enum-c-type c-type-setter
  31    [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
  32
  33 : define-enum-value ( class value -- )
  34     enum>number "enum-value" set-word-prop ;
  35
  36 <PRIVATE
  37
  38 : define-enum-members ( members -- )
  39     [ first define-singleton-class ] each ;
  40
  41 : define-enum-constructor ( word -- )
  42     [ name>> "<" ">" surround create-word-in ] keep
  43     [ number>enum ] curry ( number -- enum ) define-declared ;
  44
  45 PRIVATE>
  46
  47 : (define-enum) ( word base-type members -- )
  48     [ dup define-enum-constructor ] 2dip
  49     [ define-enum-members ]
  50     [ <enum-c-type> swap typedef ] bi ;
  51
  52 : define-enum ( word base-type members -- )
  53     [ (define-enum) ]
  54     [ [ define-enum-value ] assoc-each ] bi ;
  55
  56 PREDICATE: enum-c-type-word < c-type-word
  57     "c-type" word-prop enum-c-type? ;
  58
  59 : enum>values ( enum -- seq )
  60     "c-type" word-prop members>> values ;
  61
  62 : enum>keys ( enum -- seq )
  63     "c-type" word-prop members>> keys [ name>> ] map ;
  64
  65 : values>enum ( values enum -- seq )
  66     '[ _ number>enum ] map ; inline
  67