bootstrap.clj

(ns poet.prelude)

(def prelude
  '[(syntax-rule if ()
      (_ X Y Z) (if* (op* === X true) Y
                     (if* (op* === X false) Z
                          (throw "if requires a boolean value"))))

    (syntax-rule if-not ()
      (_ X Y Z) (if X Z Y))

    (syntax-rule when ()
      (_ X Y ...) (if X (begin Y ...) false))

    (syntax-rule when-not ()
      (_ X Y ...) (if X false (begin Y ...)))

    (syntax-rule cond ()
      (_)           false
      (_ X Y Z ...) (if X Y (cond Z ...)))
    
    (syntax-rule fn ()
      (_ (X ...) Y ...) (fn* nil nil (X ...) Y ...)
      (_ X Y ...)       (fn* nil X () Y ...))
    
    (syntax-rule method ()
      (_ THIS (X ...) Y ...) (fn* THIS nil (X ...) Y ...)
      (_ THIS X Y ...)       (fn* THIS X () Y ...))

    (syntax-rule define ()
      (_ (X YS ...) Z ...) (define* X (fn (YS ...) Z ...))
      (_ X Y)              (define* X Y))
    
    (syntax-rule define-method ()
      (_ NAME THIS (X ...) BODY ...)
      (define* NAME (method THIS (X ...) BODY ...)))
    
    (syntax-rule let ()
      (let () d ...)          ((fn () d ...))
      (let (a b c ...) d ...) ((fn (a) (let (c ...) d ...)) b))

    (syntax-rule and ()
      (and)         true
      (and X)       X
      (and X Y ...) (when X (and Y ...)))
    
    (syntax-rule or ()
      (or)         false
      (or X)       X
      (or X Y ...) (let (tmp X)
                     (if tmp tmp (or Y ...))))
    
    (syntax-rule . ()
      (. X Y)         (project* X Y)
      (. X Y (Z ...)) (invoke* X Y (Z ...)))

    ;;;; errors/adhoc-testing

    (syntax-rule assert! ()
      (_ X)   (assert! X "Assertion Failure")
      (_ X Y) (when (not X) (throw Y)))

    (syntax-rule assert-numeric! ()
      (_ X ...) (begin (assert! (number? X ...) "Numeric Type Error")))
    
    ;;;; locations
    
    (syntax-rule update! ()
      (_ TARGET MODIFIER ARGS ...)
      (set! TARGET (MODIFIER TARGET ARGS ...)))

    (syntax-rule inc! ()
      (_ TARGET) (set! TARGET (op* + TARGET 1)))

    (syntax-rule dec! ()
      (_ TARGET) (set! TARGET (op* - TARGET 1)))
    

    (syntax-rule projections ()
      (_ THIS () BODY ...)         (begin BODY ...)
  
      (_ THIS (X XS ...) BODY ...) (begin
                                    (symbol-macro X (. THIS
                                                       (syntax->string X)))
                                    (projections THIS (XS ...) BODY ...)))

    ;;;; prototypes

    (syntax-rule extend-prototype ()
      (_ PROTOTYPE (THIS FIELDS ...) (PROPERTY VALUE))
      (set! (. PROTOTYPE (syntax->string PROPERTY))
            (projections THIS (FIELDS ...) VALUE))
      
      (_ PROTOTYPE (THIS FIELDS ...) (METHOD ARGS BODY ...))
      (set! (. PROTOTYPE (syntax->string METHOD))
            (method THIS ARGS (projections THIS (FIELDS ...) BODY ...)))
      
      (_ PROTOTYPE (THIS FIELDS ...) X XS ...)
      (begin
       (extend-prototype PROTOTYPE (THIS FIELDS ...) X)
       (extend-prototype PROTOTYPE (THIS FIELDS ...) XS ...)))

    ;;;; objects

    (syntax-rule object ()
      (_ KVS ...) (let (obj (Object))
                    (object* obj KVS ...)
                    obj))
    
    (syntax-rule object* ()
      (_ O K V)          (set! (. O K) V)
      (_ O K V MORE ...) (begin
                          (object* O K V)
                          (object* O MORE ...)))

    (syntax-rule open-object ()
      (_ OBJECT (FIELD ...))
      (begin
       (define THE_OBJECT OBJECT)
       (define FIELD (. THE_OBJECT (syntax->string FIELD))) ...))

    (syntax-rule js:require ()
      (_ NAME FIELDS) (open-object (require NAME) FIELDS))
    
    ;;;; simple structs
    
    (syntax-rule define-struct ()
      (_ NAME KEY ...) (begin
                        (define-method NAME this (KEY ...)
                          (set! (. this (syntax->string KEY)) KEY) ...
                          this)
                        (let (PROTOTYPE (. NAME "prototype"))
                          (set! (. PROTOTYPE "__STRUCT_KEYS__")
                                (Array (syntax->string KEY) ...)))))

    ;;;; iteration

    (syntax-rule amap ()
      (amap (VAR ARRAY) BODY ...)
      (amap (VAR _ ARRAY) BODY ...)
      
      (amap (VAR IDX ARRAY) BODY ...)
      (let (ary ARRAY
            res (Array)
            IDX 0
            lim (. ary "length"))
        (while (< IDX lim)
          (let (VAR (. ary IDX))
            (. res "push" ((begin BODY ...)))
            (inc! IDX)))
        res))
    
    (syntax-rule aloop ()
      (aloop (VAR ARRAY) BODY ...)
      (aloop (VAR _ ARRAY) BODY ...)
      
      (aloop (VAR IDX ARRAY) BODY ...)
      (let (ary ARRAY
            IDX 0
            lim (. ary "length")
            res false)
        (while (< IDX lim)
          (let (VAR (. ary IDX))
            (set! res (begin BODY ...))
            (inc! IDX)))
        res))

    ;;;; repetitive, but now is not the time to reimplement LOOP
    
    (syntax-rule aloop* ()
      (aloop* (VAR ARRAY) BODY ...)
      (aloop* (VAR _ ARRAY) BODY ...)
      
      (aloop* (VAR IDX ARRAY) BODY ...)
      (let (ary ARRAY
            IDX (dec (. ary "length"))
            res false)
        (while (>= IDX 0)
          (let (VAR (. ary IDX))
            (set! res (begin BODY ...))
            (dec! IDX)))
        res))

    ;;;; miscellaneous helpers

    (syntax-rule -> ()
      (_ x y z ...)   (-> (-> x y) z ...)           
      (_ x (y z ...)) (y x z ...)
      (_ x y)         (y x)
      (_ x)           x)

    (syntax-rule doto ()
      (_ X (Y Z ...) ...) (let (tmp X)
                            (Y tmp Z ...) ...
                            tmp))

    ;;;; relatively type-safe math (traps NaNs etc ...)

    (syntax-rule binary-op* ()
      (_ (X Y)) (define (X a b) (assert-numeric! a b) (op* Y a b))
      (_ X)     (binary-op* (X X)))
    
    (syntax-rule define-binary-ops ()
      (_ X ...) (begin (binary-op* X) ...))
    
    (define-binary-ops + - * / < > <= >= (mod %))

    (syntax-rule definitions ()
      (_)              false
      (_ X Y MORE ...) (begin (define X Y) (definitions MORE ...)))

    (definitions

      ;;;; math/logical primitives
      ;;;; how to handle variadic functions?
      ;;;; traditionally in lisps + and * are defined as
      ;;;; (fold-left + 0 (xs ...)) and
      ;;;; (fold-left * 1 (xs ...))
      ;;;; this is primarily a concern for optimization
      ;;;; can special case them in the compiler, or redefine them
      ;;;; as fold-left ...
      ;;;; once the compiler is in javascript it can reduce the
      ;;;; folds to primitive form
      ;;;; punting for now
      
      (not X)   (op* ! X)
      (eq? X Y) (op* === X Y)

      (div X Y) (floor (/ X Y))

      ;; pull in the math functions for convenience

      rand  (. Math "rand")
      
      round (. Math "round")
      floor (. Math "floor")
      ceil  (. Math "ceil")
      abs   (. Math "abs")
   
      pow   (. Math "pow")
      sqrt  (. Math "sqrt")
      
      sin   (. Math "sin")
      cos   (. Math "cos")
      tan   (. Math "tan")
      acos  (. Math "acos")
      asin  (. Math "asin")
      atan  (. Math "atan")
      atan2 (. Math "atan2")
      
      exp   (. Math "exp")
      log   (. Math "log")
      
      max   (. Math "max")
      min   (. Math "min")

      ;;;; for easy off-by-one errors
      
      (inc X) (+ X 1)
      (dec X) (- X 1)

      ;;;; javascript types
      
      (typeof? X Y)   (eq? (op* typeof X) Y)
      (string? X)     (typeof? X "string")
      (number? X)     (and (not (NaN? X))
                           (typeof? X "number"))
      (function? X)   (typeof? X "function")
      (boolean? X)    (typeof? X "boolean")
      (nil? X)        (eq? X nil)
      (object? X)     (and (not (nil? X))
                           (typeof? X "object"))
      (undefined? X)  (typeof? X "undefined")
      (array? X)      (eq? Array (. X "constructor"))
      (array-like? X) (and (object? X)
                           (not (undefined? (. X "length"))))
      (NaN? X)        (isNaN X)
      (instance? X Y) (op* instanceof Y X)

      ;;;; objects

      (in? obj prop)               (op* in obj prop) 
      (set-property! obj prop val) (set! (. obj prop) val)
      
      ;;;; arrays : TODO - make folds generic across sequences

      (foldl f x xs)   (aloop (y xs) (set! x (f x y)))
      (foldr f x xs)   (aloop* (y xs) (set! x (f x y)))
      
      ;;;; folds
      
      (sum XS)  (foldl + 0 XS)
      (prod XS) (foldl * 1 XS)

      ;;;; sequences
      ;;;; how to do interfaces/mixins in javascript?
      ;;;; would like to support parametric polymorphism

      (sequential? X) (or (in? X "sequential?")
                          (array-like? X))
      
      (empty? X) (or (eq? 0 (. X "length"))
                     (. X "container:empty?" ()))

      (first X) (if (array-like? X)
                  (. X 0)
                  (. X "sequential:first" ()))

      (rest X) (if (array-like? X)
                 (new IndexedSequence X 1)
                 (. X "sequential:rest" ()))

      (cons X Y) (new Cons X Y)

      list (fn XS (let (len (. XS "length"))
                    (if (eq? 0 len)
                      (EmptySequence)
                      (new IndexedSequence XS 0 0 len)))))

    (define EmptySequence
      (object
       "sequential?"       true
       "sequential:empty?" (fn () true)
       "sequential:first"  (fn () (throw "first called on EmptySequence"))
       "sequential:rest"   (fn () (throw "rest called on EmptySequence"))))
    
    (define-struct IndexedSequence container index start end)
    (extend-prototype (. IndexedSequence "prototype")
                      (_ container index start end)
      (sequential? true)
      (sequential:first () (. container (+ start index)))
      (sequential:rest () (if (>= (+ start index) end)
                 EmptySequence
                 (new IndexedSequence container (inc index) start end)))
      (sequential:empty? () (>= (+ start index) end)))
    
    (define-struct Cons head tail)
    (extend-prototype (. Cons "prototype") (_ head tail)
      (sequential? true)
      (sequential:first () head)
      (sequential:rest () tail)
      (sequential:empty? () false))

    (js:require "sys" (puts inspect))

    (define (dbg X) (puts (inspect X)))

    (let (my-cons (cons 42 (Array 1 2 3)))
      (dbg my-cons)
      (dbg (first my-cons))
      (dbg (first (rest my-cons)))
      (dbg (list 1 2 3 4 5)))
    

    ])

(comment

  ;;;; junkyard

  ;;;; a simple type system would enable the compiler to handle
  ;;;; partial applications with little or no runtime overhead
  
  (curry* func flen alen args)
  (fn (X)
    (let (alen* (inc alen)
                args* (. args "slice" ()))
      (. args* "push" (X))
      (if (eq? flen alen*)
        (. func "apply" (nil args*))
        (curry* func flen alen* args*))))
      
  (curry F)
  (if (undefined? (. F "curried?"))
    (let (F* (curry* F (. F "length") 0 (new Array)))
      (set-property! F* "curried?" true)
      F*)
    F)

    ;;;; not useless, but would rather move away from overuse of OO patterns

  (syntax-rule define-class ()
    (_ CLASS THIS (FIELD ...)
       (METHOD ARGS BODY ...) ...)
    (begin
     (define-struct* CLASS FIELD ...)
     (let ()
       (define PROTOTYPE (. CLASS "prototype"))      
       (extend-prototype* PROTOTYPE THIS (FIELD ...)
                          ((syntax->string METHOD) ARGS BODY ...) ...))))

    ;;;; be cautious of defining half-implementations of advanced
    ;;;; features because syntax-case is missing.
    ;;;; to bootstrap all we need are simple lists, binary trees,
    ;;;; and value-based equality
    
    (syntax-rule define-interface ()
      (define-interface NAME (METHOD THIS ARGS ...) ...)
      (begin
       (define INTERFACE (+ "I:" (syntax->string NAME)))
       (define (METHOD THIS ARGS ...)
         (. THIS (+ INTERFACE (syntax->string METHOD))
            (ARGS ...))) ...))

    (syntax-rule extend-interface ()
      (extend-interface INTERFACE CLASS                
        (NAME (THIS ARGS ...) BODY ...) ...)
      (let (PROTOTYPE (. CLASS "prototype"))
        (set! (. PROTOTYPE (+ INTERFACE (syntax->string NAME)))
              (method THIS (ARGS ...) BODY ...)) ...)

      (extend-interface A B (C (D ...) E ...) ... MORE ...)
      (begin
       (extend-interface A B (C (D ...) E ...) ...)
       (extend-interface MORE ...))))