basis/typed/typed.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors arrays classes classes.tuple combinators
   3 combinators.short-circuit definitions effects fry hints
   4 math kernel kernel.private namespaces parser quotations
   5 sequences slots words locals effects.parser
   6 locals.parser macros stack-checker.dependencies ;
   7 FROM: classes.tuple.private => tuple-layout ;
   8 IN: typed
   9
  10 ERROR: type-mismatch-error word expected-types ;
  11 ERROR: input-mismatch-error < type-mismatch-error ;
  12 ERROR: output-mismatch-error < type-mismatch-error ;
  13
  14 PREDICATE: typed-gensym < word "typed-gensym" word-prop >boolean ;
  15 PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
  16
  17 <PRIVATE
  18
  19 : unboxable-tuple-class? ( type -- ? )
  20     {
  21         [ all-slots empty? not ]
  22         [ immutable-tuple-class? ]
  23         [ final-class? ]
  24     } 1&& ;
  25
  26 ! typed inputs
  27
  28 : typed-stack-effect? ( effect -- ? )
  29     [ object = ] all? not ;
  30
  31 : input-mismatch-quot ( word types -- quot )
  32     [ input-mismatch-error ] 2curry ;
  33
  34 : depends-on-unboxing ( class -- )
  35     [ dup tuple-layout depends-on-tuple-layout ]
  36     [ depends-on-final ]
  37     bi ;
  38
  39 : (unboxer) ( type -- quot )
  40     dup unboxable-tuple-class? [
  41         dup depends-on-unboxing
  42         all-slots [
  43             [ name>> reader-word 1quotation ]
  44             [ class>> (unboxer) ] bi compose
  45         ] map [ cleave ] curry
  46     ] [ drop [ ] ] if ;
  47
  48 :: unboxer ( error-quot word types type -- quot )
  49     type "coercer" word-prop [ ] or
  50     [ dup type instance? [ word types error-quot call ] unless ]
  51     type (unboxer)
  52     compose compose ;
  53
  54 : make-unboxer ( error-quot word types -- quot )
  55     dup [ unboxer ] with with with
  56     [ swap \ dip [ ] 2sequence prepend ] map-reduce ;
  57
  58 : (unboxed-types) ( type -- types )
  59     dup unboxable-tuple-class?
  60     [
  61         dup depends-on-unboxing
  62         all-slots [ class>> (unboxed-types) ] map concat
  63     ]
  64     [ 1array ] if ;
  65
  66 : unboxed-types ( types -- types' )
  67     [ (unboxed-types) ] map concat ;
  68
  69 :: typed-inputs ( quot word types -- quot' )
  70     types unboxed-types :> unboxed-types
  71
  72     [ input-mismatch-error ] word types make-unboxer
  73     unboxed-types quot '[ _ declare @ ]
  74     compose ;
  75
  76 ! typed outputs
  77
  78 : output-mismatch-quot ( word types -- quot )
  79     [ output-mismatch-error ] 2curry ;
  80
  81 :: typed-outputs ( quot word types -- quot' )
  82     [ output-mismatch-error ] word types make-unboxer
  83     quot prepose ;
  84
  85 DEFER: make-boxer
  86
  87 : boxer ( type -- quot )
  88     dup unboxable-tuple-class?
  89     [
  90         dup depends-on-unboxing
  91         [ all-slots [ class>> ] map make-boxer ]
  92         [ [ boa ] curry ]
  93         bi compose
  94     ]
  95     [ drop [ ] ] if ;
  96
  97 : make-boxer ( types -- quot )
  98     [ [ ] ]
  99     [ [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ] if-empty ;
 100
 101 ! defining typed words
 102
 103 MACRO: (typed) ( word def effect -- quot )
 104     [ swap ] dip
 105     [
 106         nip effect-in-types swap
 107         [ [ unboxed-types ] [ make-boxer ] bi ] dip
 108         '[ _ declare @ @ ]
 109     ]
 110     [
 111         effect-out-types
 112         dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
 113     ] 2bi ;
 114
 115 : <typed-gensym> ( parent-word -- word )
 116     [ name>> "( typed " " )" surround f <word> dup ]
 117     [ "typed-gensym" set-word-prop ] bi ;
 118
 119 : unboxed-effect ( effect -- effect' )
 120     [ effect-in-types unboxed-types [ "in" swap 2array ] map ]
 121     [ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
 122
 123 M: typed-gensym stack-effect call-next-method unboxed-effect ;
 124 M: typed-gensym parent-word "typed-gensym" word-prop ;
 125 M: typed-gensym crossref? parent-word crossref? ;
 126 M: typed-gensym where parent-word where ;
 127
 128 : define-typed-gensym ( word def effect -- gensym )
 129     [ 2drop <typed-gensym> dup ]
 130     [ [ (typed) ] 3curry ]
 131     [ 2nip ] 3tri define-declared ;
 132
 133 MACRO: typed ( quot word effect -- quot' )
 134     [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
 135     [
 136         nip effect-out-types dup typed-stack-effect?
 137         [ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
 138     ] 2bi ;
 139
 140 : (typed-def) ( word def effect -- quot )
 141     [ define-typed-gensym ] 3keep
 142     [ drop [ swap "typed-word" set-word-prop ] [ [ 1quotation ] dip ] 2bi ] dip
 143     [ typed ] 3curry ;
 144
 145 : typed-def ( word def effect -- quot )
 146     dup {
 147         [ effect-in-types typed-stack-effect? ]
 148         [ effect-out-types typed-stack-effect? ]
 149     } 1|| [ (typed-def) ] [ drop nip ] if ;
 150
 151 M: typed-word subwords
 152     [ call-next-method ]
 153     [ "typed-word" word-prop ] bi suffix ;
 154
 155 PRIVATE>
 156
 157 : define-typed ( word def effect -- )
 158     [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
 159     [ drop "typed-def" set-word-prop ]
 160     [ 2drop "typed-word" word-prop \ word set-global ] 3tri ;
 161
 162 SYNTAX: TYPED:
 163     (:) define-typed ;
 164 SYNTAX: TYPED::
 165     (::) define-typed ;
 166
 167 USING: vocabs vocabs.loader ;
 168
 169 "prettyprint" vocab [ "typed.prettyprint" require ] when