CL fast prototyping of clean define for partial applications in Shen

cl-define.shen

\* This script is aimed to run on Shen 7.1 on any Common Lisp port *\

\* (load "cl-destroy.shen") *\

\* BEGIN: fast prototyping solution for partial application compatible define *\

(package cl-define [caller-list cc-define]

 \* vectors util from vectors library *\

(define vector-dense
    Vector -> (list->vector (vector->list Vector)))
(define vector->list
   Vector -> (vector->list' Vector (limit Vector) []))
(define vector->list'
  Vector 0 L -> L 
  Vector N L -> (vector->list' Vector 
                               (- N 1) 
                               (trap-error [(<-vector Vector N) | L] (/. E L))))
(define list->vector
   L -> (list->vector' L (vector (length L)) 1))
(define list->vector'
   [] Vector _ -> Vector
   [X | Y] Vector N -> (list->vector' Y (vector-> Vector N X) (+ N 1)))  

 \* list utils *\

(define prefix-list-match?
  _ [] -> true
  [X|Y] [X|Z] -> (prefix-list-match? Y Z)
  _ _ -> false)

 \* symbol utils *\

(define prefix-symbol-match?
  Symbol Prefix -> (let PS (explode (str Prefix))
                        SS (explode (str Symbol))
                        (prefix-list-match? SS PS)))


 \* property-vector utils *\

(define get-all-functions
 -> (let X [] (get-all-functions-help (vector->list (vector-dense (value shen-*property-vector*))) X)))

(define get-all-functions-help
 [] X -> X
 [ Fn | Fns ] X <- (let F (trap-error (hd (hd (hd Fn))) (/. (protect E) (fail)))
                     (if (or (= F (fail)) (prefix-symbol-match? F shen-)) (fail)
                       (get-all-functions-help Fns [F|X])))
 [ Fn | Fns ] X -> (get-all-functions-help Fns X))

(define source-callees \* dummy version : fast prototyping *\
 Source -> (let Body (tl (tl (tl Source)))
                (shen-flatten Body)))

(define callee-match?
 Callee Caller -> (trap-error (element? Callee (source-callees (get Caller shen-source))) (/. (protect E) false)))

(define caller-list
 Callee -> (caller-list-help Callee (get-all-functions) []))

(define caller-list-help
 _ [] Callers -> Callers
 Callee [X|Y] Callers -> (let NewCallers (if (callee-match? Callee X) [X|Callers] Callers)
                              (caller-list-help Callee Y NewCallers)))

 \* core *\

(defmacro curry-compatible-define
 [ cc-define Fn | Rest ] -> (let (protect PreviousArity) ( arity Fn ) 
                              [ do [ define Fn | Rest ]
                                   [ if [ = [ arity Fn ] (protect PreviousArity) ]
                                        Fn
                                        [ let (protect Callers) [ caller-list Fn ]
                                              [ do [ map [ /. (protect C) [ do [ eval-kl [ get (protect C) shen-source ] ] ] ] (protect Callers) ] Fn ] ] ] ] )))
                          
\* END: fast prototyping solution for partial application compatible define *\