extra/descriptive/descriptive.factor

   1 USING: words kernel sequences locals locals.parser
   2 locals.definitions accessors parser namespaces continuations
   3 summary definitions generalizations arrays prettyprint debugger io ;
   4 IN: descriptive
   5
   6 ERROR: descriptive-error args underlying word ;
   7
   8 M: descriptive-error error.
   9     "The word " write dup word>> pprint " encountered an error." print
  10     "Arguments:" print
  11     dup args>> stack.
  12     "Error:" print
  13     underlying>> error. ;
  14
  15 <PRIVATE
  16
  17 : rethrower ( word inputs -- quot )
  18     [ length ] keep [ [ narray ] dip swap 2array flip ] 2curry
  19     [ 2 ndip descriptive-error ] 2curry ;
  20
  21 : [descriptive] ( word def effect -- newdef )
  22     swapd in>> rethrower [ recover ] 2curry ;
  23
  24 PRIVATE>
  25
  26 : define-descriptive ( word def effect -- )
  27     [ drop "descriptive-definition" set-word-prop ]
  28     [ [ [ dup ] 2dip [descriptive] ] keep define-declared ]
  29     3bi ;
  30
  31 SYNTAX: DESCRIPTIVE: (:) define-descriptive ;
  32
  33 PREDICATE: descriptive < word
  34     "descriptive-definition" word-prop ;
  35
  36 M: descriptive definer drop \ DESCRIPTIVE: \ ; ;
  37
  38 M: descriptive definition
  39     "descriptive-definition" word-prop ;
  40
  41 SYNTAX: DESCRIPTIVE:: (::) define-descriptive ;
  42
  43 INTERSECTION: descriptive-lambda descriptive lambda-word ;
  44
  45 M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;
  46
  47 M: descriptive-lambda definition
  48     "lambda" word-prop body>> ;