extra/descriptive/descriptive.factor

   1 ! Copyright (c) 2008 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: words kernel sequences sequences.generalizations locals
   4 locals.parser fry locals.definitions accessors parser namespaces
   5 continuations summary definitions generalizations arrays
   6 prettyprint debugger io effects tools.annotations effects.parser ;
   7 IN: descriptive
   8
   9 ERROR: descriptive-error args underlying word ;
  10
  11 M: descriptive-error error.
  12     "The word " write dup word>> pprint " encountered an error." print
  13     "Arguments:" print
  14     dup args>> stack.
  15     "Error:" print
  16     underlying>> error. ;
  17
  18 <PRIVATE
  19
  20 : rethrower ( word inputs -- quot )
  21     [ length ] keep [ [ narray ] dip swap 2array flip ] 2curry
  22     [ 2 ndip descriptive-error ] 2curry ;
  23
  24 : [descriptive] ( word def effect -- newdef )
  25     swapd in>> rethrower [ recover ] 2curry ;
  26
  27 PRIVATE>
  28
  29 : make-descriptive ( word -- )
  30     dup [ ] [ def>> ] [ stack-effect ] tri [descriptive]
  31     '[ drop _ ] annotate ;
  32
  33 : define-descriptive ( word def effect -- )
  34     [ drop "descriptive-definition" set-word-prop ]
  35     [ [ [ dup ] 2dip [descriptive] ] keep define-declared ]
  36     3bi ;
  37
  38 SYNTAX: DESCRIPTIVE: (:) define-descriptive ;
  39
  40 PREDICATE: descriptive < word
  41     "descriptive-definition" word-prop >boolean ;
  42
  43 M: descriptive definer drop \ DESCRIPTIVE: \ ; ;
  44
  45 M: descriptive definition
  46     "descriptive-definition" word-prop ;
  47
  48 SYNTAX: DESCRIPTIVE:: (::) define-descriptive ;
  49
  50 INTERSECTION: descriptive-lambda descriptive lambda-word ;
  51
  52 M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;
  53
  54 M: descriptive-lambda definition
  55     "lambda" word-prop body>> ;