core/classes/tuple/parser/parser.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel sets namespaces make sequences parser
   4 lexer combinators words classes.parser classes.tuple arrays
   5 slots math assocs parser.notes classes.algebra ;
   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 , \ } parse-until % ] { } make ;
  35
  36 : parse-slot-name-delim ( end-delim string/f -- ? )
  37     #! This isn't meant to enforce any kind of policy, just
  38     #! to check for mistakes of this form:
  39     #!
  40     #! TUPLE: blahblah foo bing
  41     #!
  42     #! : ...
  43     {
  44         { [ dup not ] [ unexpected-eof ] }
  45         { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
  46         { [ 2dup = ] [ drop f ] }
  47         [ dup "{" = [ drop parse-long-slot-name ] when , t ]
  48     } cond nip ;
  49
  50 : parse-tuple-slots-delim ( end-delim -- )
  51     dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
  52
  53 : parse-slot-name ( string/f -- ? )
  54     ";" swap parse-slot-name-delim ;
  55
  56 : parse-tuple-slots ( -- )
  57     ";" parse-tuple-slots-delim ;
  58
  59 ERROR: bad-inheritance class superclass ;
  60
  61 : check-inheritance ( class1 class2 -- class1 class2 )
  62     2dup swap class<= [ bad-inheritance ] when ;
  63
  64 : parse-tuple-definition ( -- class superclass slots )
  65     CREATE-CLASS
  66     scan 2dup = [ ] when {
  67         { ";" [ tuple f ] }
  68         { "<" [
  69             scan-word check-inheritance [ parse-tuple-slots ] { } make
  70         ] }
  71         [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
  72     } case
  73     dup check-duplicate-slots
  74     3dup check-slot-shadowing ;
  75
  76 ERROR: bad-literal-tuple ;
  77
  78 : parse-slot-value ( -- )
  79     scan scan-object 2array , scan {
  80         { f [ \ } unexpected-eof ] }
  81         { "}" [ ] }
  82         [ bad-literal-tuple ]
  83     } case ;
  84
  85 : (parse-slot-values) ( -- )
  86     parse-slot-value
  87     scan {
  88         { f [ \ } unexpected-eof ] }
  89         { "{" [ (parse-slot-values) ] }
  90         { "}" [ ] }
  91         [ bad-literal-tuple ]
  92     } case ;
  93
  94 : parse-slot-values ( -- values )
  95     [ (parse-slot-values) ] { } make ;
  96
  97 GENERIC# boa>object 1 ( class slots -- tuple )
  98
  99 M: tuple-class boa>object
 100     swap prefix >tuple ;
 101
 102 ERROR: bad-slot-name class slot ;
 103
 104 : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
 105     over [ drop ] [ nip nip nip bad-slot-name ] if ;
 106
 107 : slot-named-checked ( class initials name slots -- class initials slot-spec )
 108     over [ slot-named* ] dip check-slot-exists drop ;
 109
 110 : assoc>object ( class slots values -- tuple )
 111     [ [ [ initial>> ] map ] keep ] dip
 112     swap [ [ slot-named-checked ] curry dip ] curry assoc-map
 113     [ dup <enum> ] dip update boa>object ;
 114
 115 : parse-tuple-literal-slots ( class slots -- tuple )
 116     scan {
 117         { f [ unexpected-eof ] }
 118         { "f" [ drop \ } parse-until boa>object ] }
 119         { "{" [ parse-slot-values assoc>object ] }
 120         { "}" [ drop new ] }
 121         [ bad-literal-tuple ]
 122     } case ;
 123
 124 : parse-tuple-literal ( -- tuple )
 125     scan-word dup all-slots parse-tuple-literal-slots ;