~bouncepaw/agidel

c3fa15c6c1f40c5a878f0e458e03a812877157b6 — Timur Ismagilov 5 years ago 8b401c7
Move everything to legacy
8 files changed, 0 insertions(+), 443 deletions(-)

D aeval.scm
D agidel.egg
D agidel.scm
D args.scm
D class.scm
D core.scm
D plugin.scm
D syntrans.scm
D aeval.scm => aeval.scm +0 -108
@@ 1,108 0,0 @@
(module
 agidel.aeval
 (<aeval>)
 (import scheme
         (chicken base)
         (prefix (agidel core) core/)
         (prefix (agidel plugin) plugin/)
         (srfi 1)
         (srfi 13)
         (srfi 69)
         (clojurian syntax)
         format
         matchable)
;;;;;;;;;;;;;REDO THIS ALL FROM SCRATCH !!!!!!!!!!!!!
 (define (aquote expr) `(quote ,expr))

 ;; Return object that can apply a quote or eval function to args of an Agidel
 ;; macro.
 ;; `signatures` is the hash-table.
 ;; `quote-λ` is function to call when there is 'q in signature.
 ;; `eval-λ` is function to call when there is 'a in signature.
 ;;
 ;; (define AP sigs aquote aeval)
 ;; (AP 'normal expr)
 ;; (AP 'normal+rest expr)
 ;; (AP 'rest expr)
 (define (<arg-applier-factory> signatures quote-λ eval-λ)
   (define (get-signature λ-name)
     (hash-table-ref signatures (symbol-append '/ λ-name)))

   (define (q/e->λ q/e)
     (cond
      ((eq? q/e 'q) quote-λ)
      ((eq? q/e 'e) eval-λ)))

   (define (rest λ-name . args)
     (define signature (get-signature λ-name))
     (define λ (q/e->λ signature))
     (map λ args))

   (define (normal λ-name . args)
     (define signature (get-signature λ-name))
     (define λs (map q/e->λ signature))
     (map (lambda (λ+arg)
            (apply (car λ+arg) (cdr λ+arg)))
          (zip λs args)))

   (define (normal+rest λ-name . args)
     (define signature (get-signature λ-name))
     (define normal-length (length+ signature))
     (define normal-λs (map q/e->λ (take signature normal-length)))
     (define rest-λ (q/e->λ (drop signature normal-length)))
     (append (map (lambda (λ+arg) ((car λ+arg) (cdr λ+arg)))
                  (zip normal-λs args))
             (map rest-λ (drop args normal-length))))

   (match-lambda*
    (('normal      expr) (apply normal      expr))
    (('normal+rest expr) (apply normal+rest expr))
    (('rest        expr) (apply rest        expr))))


 (define (<expr-preparer> signatures arg-applier)
   (define (get-signature λ-name)
     (hash-table-ref signatures (symbol-append '/ λ-name)))

   (lambda (expr)
     (if (not (list? expr))
         expr
         (let* ((λ-name      (string->symbol (car expr)))
                (signature   (get-signature λ-name))
                (λ-name'     (symbol-append '/agidel/ λ-name))
                (args        (cdr expr)))
           (cons λ-name'
                 (cond
                  ((symbol? signature) (arg-applier 'rest expr))
                  ((dotted-list? signature) (arg-applier 'normal+rest expr))
                  ((proper-list? signature (arg-applier 'normal expr)))))))))


 ;; Return arg-handler.
 ;; `λ-name` is a symbol representing Agidel macro name.
 ;; `signatures` is a hash-table with all the signatures.
 ;;
 ;; arg-handler is a function that makes arguments of an Agidel macro
 ;; transformed to a correct form.
 (define (<arg-handler> λ-name signatures)

   )

 (define (<aeval> plugins)
   (define signatures (plugin/signatures plugins))
   ;; Load all Agidel `plugins`
   (->> plugins
        (map (lambda (p)
               `(prefix ,(symbol-append 'agidel-plugin. p) /agidel)))
        (cons 'import)
        eval)
   (define arg-applier (<arg-applier-factory> signatures))
   (define expr-preparer (<expr-preparer> signatures arg-applier))

   (match-lambda*
    (('prepare expr) (expr-preparer expr))
    (('run expr)
     (lambda (expr)
       (->> expr
            (map eval)
            string-join))))))

D agidel.egg => agidel.egg +0 -29
@@ 1,29 0,0 @@
((author "Timur Ismagilov")
 (synopsis "Agidel transpiler")
 (license "MIT")
 (dependencies srfi-69 srfi-1 format clojurian)
 (components
  (extension agidel.core
             (source "core.scm"))
  (extension agidel.class
             (source "class.scm")
             (component-dependencies agidel.core))
  (extension agidel.plugin
             (source "plugin.scm")
             (component-dependencies agidel.core))
  (extension agidel.syntrans
             (source "syntrans.scm")
             (component-dependencies agidel.core))
  (extension agidel.args
             (source "args.scm")
             (component-dependencies agidel.core))
  (extension agidel.aeval
             (source "aeval.scm")
             (component-dependencies agidel.core agidel.plugin))
  (program agidel
           (source "agidel.scm")
           (component-dependencies agidel.core
                                   agidel.plugin
                                   agidel.syntrans
                                   agidel.args))
  ))

D agidel.scm => agidel.scm +0 -35
@@ 1,35 0,0 @@
#|
This is the main file in the whole Agidel ecosystem.
|#
(import (chicken process-context)
        (chicken io)
        (chicken file)
        (chicken string)
        (srfi 69)
        (srfi 13)
        (srfi 1)
        (prefix (agidel core) agidel/)
        (prefix (agidel plugin) plugin/)
        (prefix (agidel syntrans) syntrans/)
        (prefix (agidel args) args/)
        format
        (clojurian syntax))

(define enable-agilog? #t)
(define (agilog . os)
  (when enable-agilog? (apply format #t os)))


;; Main
(let* ((args           (args/traverse (command-line-arguments)))
       (files          (hash-table-ref args 'files))
       (plugins        (hash-table-ref args 'plugins))
       (syntrans-λ     (syntrans/compose-λ (hash-table-ref args 'syntranses))))
  (format #t "~A" (-> (lambda (f)
                        (-> f
                            open-input-file
                            (as-> x (read-string #f x))
                            (as-> x (syntrans-λ x plugins))))
                      (map files)
                      (string-join "\n" 'suffix)))
  )

D args.scm => args.scm +0 -76
@@ 1,76 0,0 @@
(module
 agidel.args
 (traverse)
 (import scheme
         (chicken base)
         (srfi 69)
         format
         (prefix (agidel core) agidel/))

 
 ;; When an arg specifying extension to load is not loaded, defaults are
 ;; applied. This function does exactly that.
 (define (apply-defaults args-hash)
   (define default-hash
     (alist->hash-table '((plugins c)
                          (syntranses discomment
                                      disbrace
                                      disbracket
                                      quotify
                                      prepare
                                      run)
                          (files))))
   (hash-table-merge args-hash default-hash))

 ;; Syntax faciliation for `traverse`.
 (define (string=?2 str o1 o2)
   (or (string=? str o1) (string=? str o2)))

 ;; Syntax faciliation for `traverse`.
 (define-syntax set-args-hash
   (syntax-rules (args-hash)
     [(_ key val)
      (hash-table-set! args-hash key val)]
     [(_ key fun val)
      (hash-table-set! args-hash
                       key
                       (fun val (hash-table-ref args-hash key)))]))

 ;; Print help message to stdout. TODO: add actual help here.
 (define (show-help-message)
   (format #t "Agidel transpiler. You are welcome!\n"))

 ;; Parse CLI `args` and return hash map:
 ;;   key
 ;;   files:      list of filenames (as strings) to transpile
 ;;   syntranses: list of syntranses (as symbols) to use
 ;;   plugins:    list of plugins (as symbols) to use
 ;; `args` is a list of string CLI arguments. They are returned by function
 ;;  (command-line-arguments).
 (define (traverse args)
   (apply-defaults
    (let loop ((args-hash (alist->hash-table '((files))))
               (args args))
      (cond
       ;; When hit end.
       [(null? args) args-hash]
       ;; When asked for help.
       [(string=?2 (car args) "-h" "--help")
        (show-help-message)
        (exit)]
       ;; When setting full syntrans list.
       [(string=?2 (car args) "-s" "--syntranses")
        (set-args-hash 'syntranses (car (agidel/parse-string (cadr args))))
        (loop args-hash (cddr args))]
       ;; When just prepending syntrans list.
       [(string=?2 (car args) "-r" "--prepend-syntranses")
        (set-args-hash 'syntranses append (car (agidel/parse-string (cadr args))))
        (loop args-hash (cddr args))]
       ;; When setting plugin list
       [(string=?2 (car args) "-p" "--plugins")
        (set-args-hash 'plugins (car (agidel/parse-string (cadr args))))
        (loop args-hash (cddr args))]
       ;; Otherwise consider argument as filename.
       [else
        (set-args-hash 'files cons (car args))
        (loop args-hash (cdr args))])))))

D class.scm => class.scm +0 -43
@@ 1,43 0,0 @@
(module
 agidel.class
 *
 (import scheme
         (chicken base)
         coops)

 (define-class <a-meta> ()
   ((val initform: "")))

 (define-class <a-number> (<a-meta>)
   ((val initform: "0")))

 (define-class <a-string> (<a-meta>)
   ((val initform: "\"\"")))

 (define-class <a-symbol> (<a-meta>)
   ((val initform: "?")))

 (define-class <a-bool> (<a-meta>)
   ((val initform: "false")))

 (define-method (as-string (obj <a-meta>))
   (slot-value obj 'val))
 (define-method (as-inside-string (obj <a-string>))
   (let* [[val (slot-value obj 'val)]
          [len (string-length val)]]
     (substring val 1 (- len 1))))

 (define-method (as-number (obj <a-number>))
   (string->number (slot-value obj 'val)))
 (define-method (as-number (obj <a-bool>))
   (if (string=? (slot-value obj 'val) "true") 1 0))

 (define-method (as-symbol (obj <a-symbol>))
   (string->symbol (slot-value obj 'val)))
 (define-method (as-symbol (obj <a-bool>))
   (string->symbol (slot-value obj 'val)))

 (define-method (as-bool (obj <a-bool>))
   (if (string=? (slot-value obj 'val) "true") #t #f))

 )

D core.scm => core.scm +0 -104
@@ 1,104 0,0 @@
(module
 agidel.core
 (disdot dotify parse-string mirror-set! add-to-list add-to-list!
         extension-files importify)
 (import scheme
         (chicken base)
         (chicken string)
         (chicken port)
         (chicken process-context)
         (chicken file)
         srfi-13
         srfi-1
         (clojurian syntax)
         format)

 #|
 ;;; Global constants
 ;; Main Agidel directory.
 (define agidel-dir (get-environment-variable "AGIDEL_DIR"))
 ;; Directory where Agidel plugin modules are stored.
 (define plugins-dir (get-environment-variable "AGIDEL_PLUGINS_DIR"))
 ;; Plugin names that are installed in `plugins-dir`.
 (define installed-plugins (map string->symbol
 (filter
 (lambda (file) (car (string-split file ".")))
 (directory plugins-dir))))
 ;; Plugins that are asked to be loaded by the transpiler.
 (define plugins-to-load (get-environment-variable "AGIDEL_LOAD_PLUGINS"))
 |#

 ;; (add-to-list '(a b) 'c) → (a b c)
 (define (add-to-list lst elt)
   (append lst (list elt)))

 (define-syntax add-to-list!
   (syntax-rules ()
     ((_ lst elt) (set! lst (add-to-list lst elt)))))
 
 ;; (disdot '(1 2 3 .4)) → (1 2 3 4)
 (define (disdot dotted-list)
   (append (take dotted-list (length+ dotted-list))
           (list (cdr (take-right dotted-list 1)))))

 ;; (dotify '(1 2 3 4)) → (1 2 3 . 4)
 (define (dotify proper-list)
   (append (take proper-list (- (length proper-list) 1))
           (car (take-right proper-list 1))))


 ;; `source-string`: string with `prepare`d Agidel source code. This
 ;; function parses it and returns it as list of lists, where each
 ;; list if result of reading a list in `source-string`. Like that:
 ;;
 ;; (parse-string "(foo bar) (baz)")
 ;; ⇒ ((foo bar) (baz))
 (define (parse-string source-string)
   (with-input-from-string source-string
     (lambda () (port-map (lambda (x) x) read))))
 
 ;; As it can happen so that no `set!` is available when creating a new Agidel
 ;; plugin, this module provides its 'mirror'.
 (define-syntax mirror-set!
   (syntax-rules ()
     ((_ var expr) (set! var expr))))


 ;; This function returns list of files which corresponds to list of syntranses
 ;; or plugins to load.
 ;;
 ;; `lst`           : list of syntranses or plugins as symbols.
 ;; `name`          : "plugin" or "syntrans".
 ;; `plural-suffix` : "s"      or "es".
 (define (extension-files lst name plural-suffix)
   (let* ((agidel-dir (get-environment-variable "AGIDEL_DIR"))
          (path (if agidel-dir
                    (string-append agidel-dir "/" name "/")
                    (string-append (get-environment-variable "HOME")
                                   "/.agidel/" name "/")))
          (needed-exts (map (lambda (f) (string-append f ".scm"))
                            (map symbol->string lst)))
          (local-exts (directory path))
          (matched-exts (lset-intersection string=? needed-exts local-exts)))
     (if (eq? (length matched-exts) (length needed-exts))
         (map (lambda (f) (string-append path f)) matched-exts)
         (begin
           (format (current-error-port)
                   "Agidel: could not load ~A~A: ~S\n"
                   name
                   plural-suffix
                   (lset-difference string=? needed-exts matched-exts))
           (exit 1)))))

 
 ;; Make valid import directive for the `import` macro for each element in
 ;; `lst`.
 (define (importify lst sym)
   (map (lambda (st)
          (list 'prefix
                (symbol-append 'agidel- sym (string->symbol ".") st)
                (symbol-append st '/)))
        lst))
 )



D plugin.scm => plugin.scm +0 -26
@@ 1,26 0,0 @@
(module
 agidel.plugin
 (suffix-/_agidel-arities
  signatures)
 (import scheme
         (chicken base)
         (chicken process-context)
         (chicken string)
         (prefix (agidel core) agidel/)
         (srfi 69))

 ;; Append '/_agidel-arities to each element of `lst`.
 (define (suffix-/_agidel-arities lst)
   (map (lambda (p) (symbol-append p '/_agidel-arities)) lst))
 
 ;; Return hash-table, where keys are function names and values are
 ;; lists like that: (q e q q . e). You know that well amigo.
 ;;
 ;; `plugins` is list of plugins to use.
 (define (signatures plugins)
   (eval (cons 'import (agidel/importify plugins 'plugin))) ; Import them
   (foldl hash-table-merge
          (make-hash-table)
          (reverse (map eval (suffix-/_agidel-arities plugins)))))

 )

D syntrans.scm => syntrans.scm +0 -22
@@ 1,22 0,0 @@
(module
 agidel.syntrans
 (compose-λ)
 (import scheme
         (chicken base)
         (prefix (agidel core) agidel/))

 ;; Append '/main to each element of `lst`.
 (define (suffix-/main lst)
   (map (lambda (st) (symbol-append st '/main)) lst))


 ;; Return unary function which accepts a string and returns a string after
 ;; syntax transformation.
 ;;
 ;; `syntranses` is list of syntranses to use.
 (define (compose-λ syntranses)
   (eval (cons 'import (agidel/importify syntranses 'syntrans))) ; Import them
   (eval (list 'lambda '(source plugins) ; And create function from them
               (foldl (lambda (acc next) (list next acc 'plugins))
                      'source
                      (suffix-/main syntranses))))))