extra/descriptive/descriptive.factor

   1 ! Copyright (c) 2008 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays continuations debugger definitions
   4 effects effects.parser generalizations io kernel
   5 locals.definitions locals.parser prettyprint sequences
   6 sequences.generalizations tools.annotations words ;
   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 M: descriptive reset-word
  49     [ call-next-method ]
  50     [ "descriptive-definition" remove-word-prop ] bi ;
  51
  52 SYNTAX: DESCRIPTIVE:: (::) define-descriptive ;
  53
  54 PREDICATE: descriptive-lambda < descriptive lambda-word? ;
  55
  56 M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;
  57
  58 M: descriptive-lambda definition
  59     "lambda" word-prop body>> ;
  60
  61 M: descriptive-lambda reset-word
  62     [ call-next-method ] [ "lambda" remove-word-prop ] bi ;