kraken/new_kraken.kp

(let (

    ; First quick lookup function, since maps are not built in
    get-value-helper (rec-lambda recurse (dict key i) (if (>= i (len dict))
                                                    nil
                                                    (if (= key (idx (idx dict i) 0))
                                                        (idx (idx dict i) 1)
                                                        (recurse dict key (+ i 1)))))
    get-value (lambda (dict key) (get-value-helper dict key 0))

    ; Our actual method call function
    method-call (lambda (object method & arguments) (let (method_fn (get-value (meta object) method))
                                                                (if (= method_fn nil)
                                                                    (println "no method " method)
                                                                    (lapply method_fn (concat [object] arguments)))))


    make_constructor (lambda (name members methods)
        `(~rec-lambda ~name ~members
            (~with-meta [,members]
                [,(map_with_idx (lambda (i x) [array `'~x (lambda (o) (idx o i))]) members)
                 ,(map (lambda (x) [array `'~(idx x 0) (idx x 1)]) methods)])))


    ; {} body translated to do and let
    construct_body (rec-lambda recurse (is_do current to_add i)
        (if (> (len to_add) i)
            (cond (and is_do (= (len (idx to_add i)) 1)) (recurse true (concat current [(idx (idx to_add i) 0)]) to_add (+ i 1))
                  (= (len (idx to_add i)) 1)             (concat current [(recurse true [do (idx (idx to_add i) 0)] to_add (+ i 1))])
                  (= (len (idx to_add i)) 3)             (concat current [[with_import (idx (idx to_add i) 0) (recurse false [do] to_add (+ i 1))]])
                  true                                   (concat current [(recurse false [let [(idx (idx to_add i) 0) (idx (idx to_add i) 1)] ] to_add (+ i 1))]))
            current))


    ; string interpolation
    remove_dollar (rec-lambda recurse (done to_do i j) (cond (>= j (- (len to_do) 2)) (str done (slice to_do i -1))
                                            (= "\\$" (slice to_do j (+ j 2))) (recurse (str done (slice to_do i j) "$") to_do (+ j 2) (+ j 2))
                                            true                              (recurse done to_do i (+ j 1))))
    fixup_str_parts (lambda (s) (remove_dollar "" (slice s 0 -2) 0 0))



   new_kraken_untyped (concat basic_rules [

        [ 'expr [ 'number ]          (lambda (x) x) ]
        [ 'expr [ 'string ]          (lambda (x) x) ]
        [ 'expr [ 'bool_nil_symbol ] (lambda (x) x) ]

        [ 'call_innards [ 'WS * ]                 (lambda (_)   []) ]
        [ 'call_innards [ 'expr [ 'WS 'expr ] * ] (lambda (f r) (concat [f] (map (lambda (x) (idx x 1)) r))) ]

        [ 'expr ['expr "\\." 'bool_nil_symbol]    (lambda (o _ m) `(~method-call ~o '~m)) ]
        ; params
        [ 'expr ['expr "\\." 'bool_nil_symbol "\\(" 'call_innards "\\)"]
                                    (lambda (o _ m _ p _) `(~method-call ~o '~m ,p)) ]


        [ 'expr [ "\\|" 'call_innards "\\|" 'WS * 'expr ]
                    (lambda (_ params _ _ body) `(lambda (,params) ~body)) ]

        ; Call functions with function first, c style (notice no whitespace)
        [ 'expr [ 'expr "\\(" 'call_innards "\\)" ]
                    (lambda (f _ ps _) (concat [f] ps)) ]

        ; fun syntax
        [ 'block_member [ "fun" 'WS 'bool_nil_symbol 'WS * "\\(" 'call_innards "\\)" 'WS * 'expr ]
            (lambda (_ _ name _ _ params _ _ body) `(~name (~lambda (,params) ~body))) ]

        [ 'block_member [ 'expr ] (lambda (x) [x]) ]
        [ 'block_member [ "let" 'WS * 'bool_nil_symbol 'WS * "=" 'WS * 'expr ]
                                    (lambda (_ _ name _ _ _ rhs) `(~name ~rhs)) ]
        ; object syntax
        [ 'block_member ["obj" 'WS 'bool_nil_symbol "\\(" ['WS * 'bool_nil_symbol] * 'WS * "\\)" 'WS * "{" 'WS * ['bool_nil_symbol 'WS * 'expr 'WS *] *  "}"]
            (lambda (_ _ name _ members _ _ _ _ _ methods _)
                [name (make_constructor name (map (lambda (x) (idx x 1)) members)
                                             (map (lambda (x) [(idx x 0) (idx x 2)]) methods))]) ]
        ; import
        [ 'block_member [ "with_import" 'WS 'string 'WS * ":" ]
            (lambda (_ _ file _ _) [file 0 0]) ]

        [ 'expr ["{" 'WS * 'block_member "}"]
            (lambda (_ _ inner _) (construct_body true [do] [inner] 0)) ]
        [ 'expr ["{" 'WS * [ 'block_member 'WS ] * "}"]
            (lambda (_ _ inner _) (construct_body true [do] (map (lambda (x) (idx x 0)) inner) 0)) ]

        [ 'new_kraken_start_symbol [ 'WS * [ 'block_member 'WS ] * ]
            (lambda (_ inner) (construct_body true [do] (map (lambda (x) (idx x 0)) inner) 0)) ]


        [ 'expr [ "$\"" [ "(#|[%-[]|	|[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*$" 'expr ] * "(#|[%-[]|	|[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*\"" ]
            (lambda (_ string_expr_pairs end) `(str ,( flat_map (lambda (x) [ (fixup_str_parts (idx x 0)) (idx x 1) ]) string_expr_pairs) ~(fixup_str_parts end))) ]

   ]))
   (provide new_kraken_untyped)
)