extra/python/syntax/syntax.factor

   1 USING: accessors arrays combinators effects effects.parser fry generalizations
   2 kernel lexer locals math namespaces parser python python.ffi python.objects
   3 sequences sequences.generalizations vocabs.parser words ;
   4 IN: python.syntax
   5
   6 <PRIVATE
   7
   8 SYMBOL: current-context
   9
  10 : with-each-definition ( quot -- )
  11     scan-token dup ";" = [ 2drop ] [
  12         scan-effect rot [ call( tok eff -- ) ] keep with-each-definition
  13     ] if ; inline recursive
  14
  15 : scan-definitions ( quot -- )
  16     scan-token current-context set "=>" expect with-each-definition ; inline
  17
  18 : gather-args-quot ( in-effect -- quot )
  19     dup ?last "**" = [
  20         but-last length '[ [ _ narray array>py-tuple ] dip ]
  21     ] [
  22         length '[ _ narray array>py-tuple f ]
  23     ] if ;
  24
  25 : unpack-value-quot ( out-effect -- quot )
  26     length {
  27         { 0 [ [ drop ] ] }
  28         { 1 [ [ ] ] }
  29         [ '[ py-tuple>array _ firstn ] ]
  30     } case ;
  31
  32 : make-function-quot ( obj-quot effect -- quot )
  33     [ in>> gather-args-quot ] [ out>> unpack-value-quot ] bi
  34     swapd '[ @ @ -rot call-object-full @ ] ;
  35
  36 : make-factor-words ( module name prefix? -- call-word obj-word )
  37     [ [ ":" glue ] [ ":$" glue ] 2bi ] [ nip dup "$" prepend ] if
  38     [ create-in ] bi@ ;
  39
  40 : import-getattr ( module name -- alien )
  41     [ py-import ] dip getattr ;
  42
  43 :: add-function ( name effect module prefix? -- )
  44     module name prefix? make-factor-words :> ( call-word obj-word )
  45     obj-word module name '[ _ _ import-getattr ] ( -- o ) define-inline
  46     call-word obj-word def>> effect make-function-quot effect define-inline ;
  47
  48 : make-method-quot ( name effect -- quot )
  49     [ in>> rest gather-args-quot ] [ out>> unpack-value-quot ] bi swapd
  50     '[ @ rot _ getattr -rot call-object-full @ ] ;
  51
  52 : method-callable ( name effect -- )
  53     [ dup create-in swap ] dip [ make-method-quot ] keep define-inline ;
  54
  55 : method-object ( name -- )
  56     [ "$" prepend create-in ] [ '[ _ getattr ] ] bi
  57     { "obj" } { "obj'" } <effect> define-inline ;
  58
  59 : add-method ( name effect -- )
  60     dupd method-callable method-object ;
  61
  62 PRIVATE>
  63
  64 SYNTAX: PY-FROM: [
  65     current-context get f add-function
  66 ] scan-definitions ; inline
  67
  68 SYNTAX: PY-QUALIFIED-FROM: [
  69     current-context get t add-function
  70 ] scan-definitions ; inline
  71
  72 SYNTAX: PY-METHODS: [ add-method ] scan-definitions ; inline