extra/pair-methods/pair-methods.factor

   1 ! Copyright (C) 2009 Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs classes classes.tuple.private combinators
   4 effects.parser generic.parser kernel math math.order parser
   5 quotations sequences sorting words ;
   6 IN: pair-methods
   7
   8 ERROR: no-pair-method a b generic ;
   9
  10 : ?swap ( a b ? -- a/b b/a )
  11     [ swap ] when ;
  12
  13 : method-sort-key ( pair -- key )
  14     first2 [ tuple-layout third ] bi@ + ;
  15
  16 : pair-match-condition ( pair -- quot )
  17     first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence
  18     [ 2dup ] [ bi* and ] surround ;
  19
  20 : pair-method-cond ( pair quot -- array )
  21     [ pair-match-condition ] [ ] bi* 2array ;
  22
  23 : sorted-pair-methods ( word -- alist )
  24     "pair-generic-methods" word-prop >alist
  25     [ first method-sort-key ] inv-sort-with ;
  26
  27 : pair-generic-definition ( word -- def )
  28     [ sorted-pair-methods [ first2 pair-method-cond ] map ]
  29     [ [ no-pair-method ] curry suffix ] bi 1quotation
  30     [ 2dup [ class-of ] compare +gt+ eq? ?swap ] [ cond ] surround ;
  31
  32 : make-pair-generic ( word -- )
  33     dup pair-generic-definition define ;
  34
  35 : define-pair-generic ( word effect -- )
  36     [ swap set-stack-effect ]
  37     [ drop H{ } clone "pair-generic-methods" set-word-prop ]
  38     [ drop make-pair-generic ] 2tri ;
  39
  40 : (PAIR-GENERIC:) ( -- )
  41     scan-new-generic scan-effect define-pair-generic ;
  42
  43 SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ;
  44
  45 : define-pair-method ( a b pair-generic definition -- )
  46     [ 2array ] 2dip swap
  47     [ "pair-generic-methods" word-prop swapd set-at ]
  48     [ make-pair-generic ] bi ;
  49
  50 : ?prefix-swap ( quot ? -- quot' )
  51     [ \ swap prefix ] when ;
  52
  53 : (PAIR-M:) ( -- )
  54     scan-word scan-word 2dup <=> +gt+ eq? [
  55         ?swap scan-word parse-definition
  56     ] keep ?prefix-swap define-pair-method ;
  57
  58 SYNTAX: PAIR-M: (PAIR-M:) ;