core/classes/tuple/parser/parser.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes.parser classes.tuple
   4 combinators kernel lexer make parser parser.notes sequences
   5 sets slots ;
   6 IN: classes.tuple.parser
   7
   8 : slot-names ( slots -- seq )
   9     [ dup array? [ first ] when ] map ;
  10
  11 : shadowed-slots ( superclass slots -- shadowed )
  12     [ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
  13
  14 : check-slot-shadowing ( class superclass slots -- )
  15     shadowed-slots [
  16         [
  17             "Definition of slot ``" %
  18             %
  19             "'' in class ``" %
  20             name>> %
  21             "'' shadows a superclass slot" %
  22         ] "" make note.
  23     ] with each ;
  24
  25 ERROR: duplicate-slot-names names ;
  26
  27 : check-duplicate-slots ( slots -- )
  28     slot-names duplicates
  29     [ duplicate-slot-names ] unless-empty ;
  30
  31 ERROR: invalid-slot-name name ;
  32
  33 : parse-long-slot-name ( -- spec )
  34     [ scan-token , \ } parse-until % ] { } make ;
  35
  36 : parse-slot-name-delim ( end-delim string/f -- ? )
  37     ! Check for mistakes of this form:
  38     !
  39     ! TUPLE: blahblah foo bing
  40     !
  41     ! : ...
  42     {
  43         { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
  44         { [ 2dup = ] [ drop f ] }
  45         [ dup "{" = [ drop parse-long-slot-name ] when , t ]
  46     } cond nip ;
  47
  48 : parse-tuple-slots-delim ( end-delim -- )
  49     dup scan-token parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
  50
  51 : parse-slot-name ( string/f -- ? )
  52     ";" swap parse-slot-name-delim ;
  53
  54 : parse-tuple-slots ( -- )
  55     ";" parse-tuple-slots-delim ;
  56
  57 : (parse-tuple-definition) ( word -- class superclass slots )
  58     scan-token {
  59         { ";" [ tuple f ] }
  60         { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
  61         [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
  62     } case
  63     dup check-duplicate-slots
  64     3dup check-slot-shadowing ;
  65
  66 : parse-tuple-definition ( -- class superclass slots )
  67     scan-new-class (parse-tuple-definition) ;
  68
  69
  70 ERROR: bad-literal-tuple ;
  71
  72 ERROR: bad-slot-name class slot ;
  73
  74 : check-slot-name ( class slots name -- name )
  75     2dup swap slot-named [ 2nip ] [ nip bad-slot-name ] if ;
  76
  77 : parse-slot-value ( class slots -- )
  78     scan-token check-slot-name scan-object 2array , scan-token {
  79         { "}" [ ] }
  80         [ bad-literal-tuple ]
  81     } case ;
  82
  83 : (parse-slot-values) ( class slots -- )
  84     2dup parse-slot-value
  85     scan-token {
  86         { "{" [ (parse-slot-values) ] }
  87         { "}" [ 2drop ] }
  88         [ 2nip bad-literal-tuple ]
  89     } case ;
  90
  91 : parse-slot-values ( class slots -- values )
  92     [ (parse-slot-values) ] { } make ;
  93
  94 GENERIC#: boa>object 1 ( class slots -- tuple )
  95
  96 M: tuple-class boa>object
  97     swap slots>tuple ;
  98
  99 : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
 100     over [ drop ] [ 3nip bad-slot-name ] if ;
 101
 102 : slot-named-checked ( class initials name slots -- class initials slot-spec )
 103     over [ slot-named* ] dip check-slot-exists drop ;
 104
 105 : assoc>object ( class slots values -- tuple )
 106     [ [ [ initial>> ] map <enumerated> ] keep ] dip
 107     swap [ [ slot-named-checked ] curry dip ] curry assoc-map
 108     assoc-union! seq>> boa>object ;
 109
 110 : parse-tuple-literal-slots ( class slots -- tuple )
 111     scan-token {
 112         { "f" [ drop \ } parse-until boa>object ] }
 113         { "{" [ 2dup parse-slot-values assoc>object ] }
 114         { "}" [ drop new ] }
 115         [ bad-literal-tuple ]
 116     } case ;
 117
 118 : parse-tuple-literal ( -- tuple )
 119     scan-word dup all-slots parse-tuple-literal-slots ;