extra/roles/roles.factor

   1 ! Copyright (C) 2009 Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays classes.mixin classes.parser
   4 classes.tuple classes.tuple.parser combinators kernel lexer make
   5 parser sequences sets strings words ;
   6 IN: roles
   7
   8 ERROR: role-slot-overlap class slots ;
   9 ERROR: multiple-inheritance-attempted classes ;
  10
  11 PREDICATE: role < mixin-class
  12     "role-slots" word-prop >boolean ;
  13
  14 : parse-role-definition ( -- class superroles slots )
  15     scan-new-class scan-token {
  16         { ";" [ { } { } ] }
  17         { "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] }
  18         { "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] }
  19         [ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
  20     } case ;
  21
  22 : slot-name ( name/array -- name )
  23     dup string? [ first ] unless ;
  24
  25 : slot-names ( array -- names )
  26     [ slot-name ] map ;
  27
  28 : role-slots ( role -- slots )
  29     [ "superroles" word-prop [ role-slots ] map concat ]
  30     [ "role-slots" word-prop ] bi append ;
  31
  32 : role-or-tuple-slot-names ( role-or-tuple -- names )
  33     dup role?
  34     [ role-slots slot-names ]
  35     [ all-slots [ name>> ] map ] if ;
  36
  37 : check-for-slot-overlap ( class roles-and-superclass slots -- )
  38     [ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append
  39     duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ;
  40
  41 : roles>slots ( roles-and-superclass slots -- superclass slots' )
  42     [
  43         [ role? ] partition
  44         dup length {
  45             { 0 [ drop tuple ] }
  46             { 1 [ first ] }
  47             [ drop multiple-inheritance-attempted ]
  48         } case
  49         swap [ role-slots ] map concat
  50     ] dip append ;
  51
  52 : add-to-roles ( class roles -- )
  53     [ add-mixin-instance ] with each ;
  54
  55 : (define-role) ( class superroles slots -- )
  56     [ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry*
  57     [ define-mixin-class ] tri ;
  58
  59 : define-role ( class superroles slots -- )
  60     [ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ;
  61
  62 : define-tuple-class-with-roles ( class roles-and-superclass slots -- )
  63     [ check-for-slot-overlap ]
  64     [ roles>slots define-tuple-class ]
  65     [ drop [ role? ] filter add-to-roles ] 3tri ;
  66
  67 SYNTAX: ROLE: parse-role-definition define-role ;
  68 SYNTAX: ROLE-TUPLE: parse-role-definition define-tuple-class-with-roles ;