extra/typed/typed.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors arrays combinators combinators.short-circuit
   3 definitions effects fry hints math kernel kernel.private namespaces
   4 parser quotations see.private sequences words
   5 locals locals.definitions locals.parser ;
   6 IN: typed
   7
   8 ERROR: type-mismatch-error word expected-types ;
   9 ERROR: input-mismatch-error < type-mismatch-error ;
  10 ERROR: output-mismatch-error < type-mismatch-error ;
  11
  12 ! typed inputs
  13
  14 : typed-stack-effect? ( effect -- ? )
  15     [ object = ] all? not ;
  16
  17 : input-mismatch-quot ( word types -- quot )
  18     [ input-mismatch-error ] 2curry ;
  19
  20 : make-coercer ( types -- quot )
  21     [ "coercer" word-prop [ ] or ]
  22     [ swap \ dip [ ] 2sequence prepend ]
  23     map-reduce ;
  24
  25 : typed-inputs ( quot word types -- quot' )
  26     {
  27         [ 2nip make-coercer ]
  28         [ 2nip make-specializer ]
  29         [ nip swap '[ _ declare @ ] ]
  30         [ [ drop ] 2dip input-mismatch-quot ]
  31     } 3cleave '[ @ @ _ _ if ] ;
  32
  33 ! typed outputs
  34
  35 : output-mismatch-quot ( word types -- quot )
  36     [ output-mismatch-error ] 2curry ;
  37
  38 : typed-outputs ( quot word types -- quot' )
  39     {
  40         [ 2drop ]
  41         [ 2nip make-coercer ]
  42         [ 2nip make-specializer ]
  43         [ [ drop ] 2dip output-mismatch-quot ]
  44     } 3cleave '[ @ @ @ _ unless ] ;
  45
  46 ! defining typed words
  47
  48 : typed-gensym-quot ( def word effect -- quot )
  49     [ nip effect-in-types swap '[ _ declare @ ] ]
  50     [ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ;
  51
  52 : typed-gensym ( parent-word -- word )
  53     name>> "( typed " " )" surround f <word> ;
  54
  55 : define-typed-gensym ( word def effect -- gensym )
  56     [ 2drop typed-gensym dup ]
  57     [ [ swap ] dip typed-gensym-quot ]
  58     [ 2nip ] 3tri define-declared ;
  59
  60 PREDICATE: typed-standard-word < word "typed-word" word-prop ;
  61 PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
  62
  63 UNION: typed-word typed-standard-word typed-lambda-word ;
  64
  65 : typed-quot ( quot word effect -- quot' )
  66     [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
  67     [ nip effect-out-types dup typed-stack-effect? [ '[ @ _ declare ] ] [ drop ] if ] 2bi ;
  68
  69 : (typed-def) ( word def effect -- quot )
  70     [ define-typed-gensym ] 3keep
  71     [ drop [ swap "typed-word" set-word-prop ] [ [ 1quotation ] dip ] 2bi ] dip
  72     typed-quot ;
  73
  74 : typed-def ( word def effect -- quot )
  75     dup {
  76         [ effect-in-types typed-stack-effect? ]
  77         [ effect-out-types typed-stack-effect? ]
  78     } 1|| [ (typed-def) ] [ drop nip ] if ;
  79
  80 : define-typed ( word def effect -- )
  81     [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
  82     [ drop "typed-def" set-word-prop ]
  83     [ 2drop "typed-word" word-prop \ word set-global ] 3tri ;
  84
  85 SYNTAX: TYPED:
  86     (:) define-typed ;
  87 SYNTAX: TYPED::
  88     (::) define-typed ;
  89
  90 M: typed-standard-word definer drop \ TYPED: \ ; ;
  91 M: typed-lambda-word definer drop \ TYPED:: \ ; ;
  92
  93 M: typed-word definition "typed-def" word-prop ;
  94 M: typed-word declarations. "typed-word" word-prop declarations. ;
  95
  96 M: typed-word subwords "typed-word" word-prop 1array ;