basis/functors/functors.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays classes.mixin classes.parser
   4 classes.singleton classes.tuple classes.tuple.parser
   5 combinators effects.parser fry functors.backend generic
   6 generic.parser interpolate io.streams.string kernel lexer
   7 locals.parser locals.types macros make namespaces parser
   8 quotations sequences vocabs.parser words words.symbol ;
   9 IN: functors
  10
  11 ! This is a hack
  12
  13 <PRIVATE
  14
  15 TUPLE: fake-call-next-method ;
  16
  17 TUPLE: fake-quotation seq ;
  18
  19 GENERIC: >fake-quotations ( quot -- fake )
  20
  21 M: callable >fake-quotations
  22     >array >fake-quotations fake-quotation boa ;
  23
  24 M: array >fake-quotations [ >fake-quotations ] { } map-as ;
  25
  26 M: object >fake-quotations ;
  27
  28 GENERIC: (fake-quotations>) ( fake -- )
  29
  30 : fake-quotations> ( fake -- quot )
  31     [ (fake-quotations>) ] [ ] make ;
  32
  33 M: fake-quotation (fake-quotations>)
  34     [ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
  35
  36 M: array (fake-quotations>)
  37     [ [ (fake-quotations>) ] each ] { } make , ;
  38
  39 M: fake-call-next-method (fake-quotations>)
  40     drop method-body get literalize , \ (call-next-method) , ;
  41
  42 M: object (fake-quotations>) , ;
  43
  44 : parse-definition* ( accum -- accum )
  45     parse-definition >fake-quotations parsed
  46     [ fake-quotations> first ] over push-all ;
  47
  48 : parse-declared* ( accum -- accum )
  49     complete-effect
  50     [ parse-definition* ] dip
  51     parsed ;
  52
  53 FUNCTOR-SYNTAX: TUPLE:
  54     scan-param parsed
  55     scan {
  56         { ";" [ tuple parsed f parsed ] }
  57         { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
  58         [
  59             [ tuple parsed ] dip
  60             [ parse-slot-name [ parse-tuple-slots ] when ] { }
  61             make parsed
  62         ]
  63     } case
  64     \ define-tuple-class parsed ;
  65
  66 FUNCTOR-SYNTAX: SINGLETON:
  67     scan-param parsed
  68     \ define-singleton-class parsed ;
  69
  70 FUNCTOR-SYNTAX: MIXIN:
  71     scan-param parsed
  72     \ define-mixin-class parsed ;
  73
  74 FUNCTOR-SYNTAX: M:
  75     scan-param parsed
  76     scan-param parsed
  77     [ create-method-in dup method-body set ] over push-all
  78     parse-definition*
  79     \ define* parsed ;
  80
  81 FUNCTOR-SYNTAX: C:
  82     scan-param parsed
  83     scan-param parsed
  84     complete-effect
  85     [ [ [ boa ] curry ] over push-all ] dip parsed
  86     \ define-declared* parsed ;
  87
  88 FUNCTOR-SYNTAX: :
  89     scan-param parsed
  90     parse-declared*
  91     \ define-declared* parsed ;
  92
  93 FUNCTOR-SYNTAX: SYMBOL:
  94     scan-param parsed
  95     \ define-symbol parsed ;
  96
  97 FUNCTOR-SYNTAX: SYNTAX:
  98     scan-param parsed
  99     parse-definition*
 100     \ define-syntax parsed ;
 101
 102 FUNCTOR-SYNTAX: INSTANCE:
 103     scan-param parsed
 104     scan-param parsed
 105     \ add-mixin-instance parsed ;
 106
 107 FUNCTOR-SYNTAX: GENERIC:
 108     scan-param parsed
 109     complete-effect parsed
 110     \ define-simple-generic* parsed ;
 111
 112 FUNCTOR-SYNTAX: MACRO:
 113     scan-param parsed
 114     parse-declared*
 115     \ define-macro parsed ;
 116
 117 FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ;
 118
 119 FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ;
 120
 121 : (INTERPOLATE) ( accum quot -- accum )
 122     [ scan interpolate-locals ] dip
 123     '[ _ with-string-writer @ ] parsed ;
 124
 125 PRIVATE>
 126
 127 SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
 128
 129 SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
 130
 131 SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
 132
 133 SYNTAX: DEFINES-PRIVATE [ begin-private create-in end-private ] (INTERPOLATE) ;
 134
 135 SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
 136
 137 DEFER: ;FUNCTOR delimiter
 138
 139 <PRIVATE
 140
 141 : push-functor-words ( -- )
 142     functor-words use-words ;
 143
 144 : pop-functor-words ( -- )
 145     functor-words unuse-words ;
 146
 147 : parse-functor-body ( -- form )
 148     push-functor-words
 149     "WHERE" parse-bindings*
 150     [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
 151     pop-functor-words ;
 152
 153 : (FUNCTOR:) ( -- word def effect )
 154     CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
 155
 156 PRIVATE>
 157
 158 SYNTAX: FUNCTOR: (FUNCTOR:) define-declared ;