lang.phn

(define "SYSTEM" (dirname __FILE__))
(define "LIB_PATH" (. SYSTEM "/lib/"))
(define "LIB_PHAREN_PATH" (. SYSTEM "/lib/pharen/"))
(set-include-path (. (get-include-path) PATH_SEPARATOR LIB_PATH PATH_SEPARATOR LIB_PHAREN_PATH))
(require "sequence.php")

(defmacro comment (&exprs)
  'NULL)

(defmacro when (c &body)
  '(if ~c
     (do
       ~@body)
     NULL))

(defmacro when-set (val)
  '(when (isset ~val) ~val))

(defmacro error (&msgs)
  '(error-log (. ~@msgs)))

(defmacro not (expr)
  '(! ~expr))

(defmacro not-set (expr)
  '(not (isset ~expr)))

(defmacro pharen-or (e1 e2)
  '(if ~e1 ~e1 ~e2)) 

(defmacro pharen-and (e1 e2)
  '(cond
     ((not ~e1) ~e1)
     ((not ~e2) ~e2)
     (TRUE      ~e2)))

(defmacro load (name)
  (def php-file (. name ".php"))
  (local file (. name ".phn"))
  (local old-node-ns (:: Node ns))
  (local old-ns (:: RootNode ns))
  (local raw-ns (:: RootNode raw-ns))
  (local old-ns_string (:: RootNode ns-string))
  (local lib-path (stream-resolve-include-path file))
  (when lib-path
    (compile-file lib-path)
    (= (:: Node ns) old-node-ns)
    (= (:: RootNode ns) old-ns)
    (= (:: RootNode ns-string) old-ns-string)
    (= (:: RootNode raw-ns) raw-ns)
    '(include ~php-file)))


(defmacro runtime (expr)
  '(let [time-start (microtime TRUE)
         result ~expr
         time-duration (- (microtime TRUE) time-start)
         time-to-display (if (> time-duration 1)
                           (. time-duration " seconds")
                           (. (* time-duration 1000)  " milliseconds"))]
     (print (. "Elapsed time: " time-to-display "\n"))
     NULL))

(defmacro thunk (&exprs)
  '(lambda () ~@exprs))

(defmacro inst? (var cls)
  '(instanceof ~var ~-cls))

(defmacro print* (&s)
  '(print (. ~@s)))

(fn first (xs)
  (-> (seq xs) (first)))
(poly-ann first (^Seq xs))
(fun first (^FastSeq xs)
     (-> xs first))

(fn rest (xs)
  (-> (seq xs) (rest)))
(poly-ann rest (^Seq xs))
(fun rest (^FastSeq xs)
     (-> xs rest))

(fn pharen-list (a &xs)
  (cons a xs))

(fn butlast (xs)
  (take (dec (count xs)) xs))

(fn last (xs)
  (:xs (dec (count xs))))

(fn eq (val1 val2)
  (cond 
    ((inst? val1 IPharenComparable) (-> val1 (eq val2)))
    ((inst? val2 IPharenComparable) (-> val2 (eq val1)))
    (TRUE (=== val1 val2))))

(defmacro if-let (binding then else)
  (def cond (:binding 1))
  '(if ~cond
     (let ~binding
       ~then)
     ~else))

(defmacro when-let (binding then)
  (def cond (:binding 1))
  '(when ~cond
     (let ~binding
       ~then)))

(defmacro if-not (cond then else)
  '(if (not ~cond)
     ~then
     ~else))

(defmacro when-not (cond &then)
  '(when (not ~cond)
     ~@then))

(defmacro dotimes (binding &exprs)
  (def varname (:binding 0))
  (def n (:binding 1))
  '((lambda (~varname --dotimes-result)
           (if (>= ~varname ~n)
             --dotimes-result
             (do
               (local --dotimes-result (do ~@exprs))
               (recur (inc ~varname) --dotimes-result)))) 0 NULL))

(fn prn (s &other)
  (let
    [str (. s (seq-join other))]
    (print* str "\n")
    NULL))

(fn false? (x)
  (=== FALSE x))

(fn true? (x)
  (=== TRUE x))

(fn null? (x)
  (=== NULL x))

(fn zero? (n)
  (=== n 0))

(fn pos? (n)
  (> n 0))

(fn neg? (n)
  (< n 0))

(fn odd? (n)
  (=== (% n 2) 1))

(fn even? (n)
  (=== (% n 2) 0))

(fn str (s1 s2)
  (. s1 s2))

(fn identity (x)
  x)

(fn inc (x)
  (+ 1 x))

(fn dec (x)
  (- x 1))

(defmacro set! (var val)
  '(local ~var ~val))

(defmacro alter (var f &args)
  '(local ~var (~$f ~var ~@args)))

(fn comp (&fs)
  (let [rfs (reverse fs)]
    (lambda (&args)
            (let [init (call-user-func-array (first rfs) (arr args))]
              (reduce #apply init (rest rfs))))))

(fn zero-or-empty? (n xs)
  (or (zero? n) (empty? xs)))

(fn empty? (xs)
  (or (inst? (seq xs) .PharenEmptyList) (not (seq xs))))
(poly-ann empty? (^Seq xs))
(fun empty? (^FastSeq xs)
     (=== (-> xs length) 0))

(fn seq? (x)
  (inst? x IPharenSeq))
(fun seq? (^Seq x)
     TRUE)

(fn sequential? (x)
  (or (inst? x IPharenSeq) (is-array x)))

(fn assoc? (x)
  (inst? x PharenHashMap))

(fn seq (x)
  (if (inst? x IPharenSeq)
    (-> x (seq))
    (:: PharenList (seqify x))))
(fun seq (^Seq x)
     x)
(fun seq (^FastSeq x)
     x)

(fn hashify (x)
  (if (inst? x PharenHashMap)
    x
    (new PharenHashMap x))) ; TODO: Do actual conversion into a hashmap-suitable data structure

(fn hash-from-pairs (pairs)
  (reduce (lambda (pair hm)
                  (assoc (:pair 0) (:pair 1) hm))
          {}
          pairs))

(fn force (x)
  (-> x (force)))

(fn realized? (x)
  (-> x (realized)))

(defmacro lazy-obj (cls &exprs)
  '(new ~cls (lambda () ~@exprs)))

(defmacro delay (expr)
  '(lazy-obj .PharenDelay ~expr))

(defmacro lazy-seq (list-expr)
  '(lazy-obj .PharenLazyList ~list-expr))

(fn arr (x)
  (cond
    ((is-array x) x)
    ((inst? x "PharenHashMap") (-> x (arr)))
    ((inst? x "IPharenSeq") (-> x (arr)))))


(defmacro second (xs)
  '(first (rest ~xs)))

(fn first-pair (xs)
  (array-slice xs 0 1))

(fn cons (x xs)
  (if (seq? xs)
    (-> xs (cons x))
    (-> (seq xs) (cons x))))
(poly-ann cons (x ^Seq xs))

(fn assoc (key val hm)
  (-> (hashify hm) (assoc key val)))

(fn get (key hm)
  (if (isset (:hm key))
    (:hm key)
    NULL))

(fn take (n xs)
  (if (zero-or-empty? n xs)
    []
    (cons (first xs) (take (- n 1) (rest xs)))))

(fn drop (n xs)
  (if (zero-or-empty? n xs)
    xs
    (drop (- n 1) (rest xs))))

(fn reverse (xs [acc []])
  (if (empty? xs)
    acc
    (reverse (rest xs) (cons (first xs) acc))))

(fn interpose (sep xs [acc []])
  (if (=== (count xs) 1)
    [(first xs)]
    (cons (first xs) (cons sep (interpose sep (rest xs))))))

(fn partition (n xs)
  (if (empty? xs)
    xs
    (cons (take n xs) (partition n (drop n xs)))))

(fn interleave (xs ys)
  (if (or (empty? xs) (empty? ys))
    []
    (cons (first xs) (cons (first ys) (interleave (rest xs) (rest ys))))))

(fn zip-with (f xs ys)
  (if (or (empty? xs) (empty? ys))
    []
    (cons ($f (first xs) (first ys))
          (zip-with f (rest xs) (rest ys)))))

(fn pharen-sort (xs)
  (let [arr (arr xs)]
    (sort arr)
    arr))

(fn seq-join (xs [glue ""])
  (implode glue (arr xs)))

(fn seq-rand (xs)
  (:xs (rand 0 (dec (count xs)))))

(fn infinity ([n 0])
  (lazy-seq (cons n (infinity (+ n 1)))))

(fn repeat (x)
  (lazy-seq (cons x (repeat x))))

(fn repeatedly (f)
  (lazy-seq (cons ($f) (repeatedly f))))

(fn iterate (f init)
  (lazy-seq (cons init (iterate f ($f init)))))

(fn cycle (xs)
  (lazy-seq (concat xs (cycle xs))))

(fn cycle-with (f xs)
  (lazy-seq
    (let [new-xs (map f xs)]
      (concat xs (cycle-with f new-xs)))))

(fn vals (m)
  (array-values (arr m)))

(fn append (x xs)
  (concat xs [x]))

(fn apply (f &args)
  (let [name (if (is-array f) (:f 0) f)
        args-array (arr (if (sequential? (last args))
                          (concat (butlast args) (last args))
                          args))]
    (when (is-array f)
      (array-push args-array (:f 1)))
    (call-user-func-array name args-array)))

(fn flip (f)
  (lambda (x y)
          ($f y x)))

(fn juxt (&fs)
    (lambda (&args)
            (map (lambda (f) (apply f args))
                 fs)))

(fn concat (xs1 xs2)
  (if (empty? xs1)
    xs2
    (cons (first xs1) (concat (rest xs1) xs2))))

(fn into (to from)
  (reduce #cons to from))

(fn reduce (f acc xs)
  (if (empty? xs)
    acc
    (reduce f ($f (first xs) acc) (rest xs))))
(poly-ann reduce (f acc ^Seq xs))
(poly-ann reduce (f acc ^FastSeq xs))

(fn reduce-fns (fns acc xs)
  (if (empty? xs)
    acc
    (reduce-fns (rest fns) ((first fns) (first xs) acc) (rest xs))))

(fn reduce-to-str (new-val-func xs)
  (reduce (lambda (val acc)
                  (. acc ($new-val-func val)))
          "" xs))

(fn reduce-pairs (f acc xs)
  (if (empty? xs)
    acc
    (reduce-pairs f ($f (each xs) acc) (rest xs))))

(fn map (f xs)
  (if (empty? xs)
    xs
    (cons ($f (first xs)) (map f (rest xs)))))

(fn filter (f coll)
  (if (empty? coll)
    []
    (let [x (first coll), xs (rest coll)]
      (if (not ($f x))
        (filter f xs)
        (cons x (filter f xs))))))

(fn until (f xs)
  (cond 
    ((empty? xs) FALSE)
    ((local result ($f (first xs))) result)
    (TRUE (until f (rest xs)))))

(fn map-indexed (f xs [idx 0])
  (if (empty? xs)
    []
    (cons ($f (first xs) idx) (map-indexed f (rest xs) (inc idx)))))

(fn map-pairs (f pairs)
  (reduce-pairs (lambda (pair acc) (append ($f (:pair 0) (:pair 1)) acc))
                []
                pairs))

(fn repling ()
  (and (defined "PHARENREPLMODE") (constant "PHARENREPLMODE")))

(defmacro attr* (access-modifier name val)
  '(access ~access-modifier (local ~name ~val)))

(defmacro attr (name val)
  '(attr* public ~name ~val))

(defmacro private-attr (name val)
  '(attr* private ~name ~val))

(defmacro static-attr (name val)
  '(attr* static ~name ~val))

(defmacro method* (access-modifier name args &code)
  '(access ~access-modifier
           (fn ~name ~args
             ~@code)))

(defmacro method (name args &code)
  '(method* public ~name ~args
            ~@code))

(defmacro private-method (name args &code)
  '(method* private ~name ~args
            ~@code))

(defmacro static-method (name args &code)
  '(method* static ~name ~args
            ~@code))

(defmacro this (&exprs)
  '(-> this ~@exprs))

(defmacro self (&expr)
  '(:: self ~@exprs))

(defmacro signature (name args)
  '(signature* public ~name ~args))

(defmacro private-signature (name args)
  '(signature* private ~name ~args))

(class MultiManager
       (access static (local multis NULL))

       (access static (fn matching-multi-exists (multi-name serialized-args)
                        (isset (:: self (:multis multi-name serialized-args)))))

       (access static (fn get-matching-multi (multi-name serialized-args)
                        (:: self (:multis multi-name serialized-args))))

       (access static (fn set-multi (multi-name pattern f)
                        (= (:: self (:multis multi-name pattern)) f))))

(= (:: MultiManager multis) {})



(fn multi-serialize-args (vals)
  (reduce-to-str (lambda (val)
                         (cond
                           ((is-string val) "str")
                           ((is-int val) "int")
                           ((is-float val) "float")
                           ((is-bool val) "bool")
                           ((is-array val) (if (isset (:val "_multitype")) (:val "_multitype") "5"))
                           ((is-object val) (get-class val))))
                 vals))

(fn multi-serialize-pattern (pattern)
  (implode (arr pattern)))

(fn get-multi (name args)
  (let [serialized-args (multi-serialize-args args)]
    (if (:: MultiManager (matching-multi-exists name serialized-args))
      (:: MultiManager (get-matching-multi name serialized-args))
      "No matching pattern")))

(defmacro defmulti (nm args)
  (def name (. nm ""))
  '(do
     (= (:: MultiManager (:multis ~name)) {})
     (fn ~nm ~args
       ((get-multi ~name (func-get-args)) ~@args))))

(defmacro defmethod (nm pattern args &body)
  (def name (. nm ""))
  '(:: MultiManager (set-multi ~name (multi-serialize-pattern ~pattern) (lambda (a) ~@body))))