<commit_before>;; -*- Mode: Irken -*-

(include "self/mbe.scm")
(include "self/types.scm")
(include "self/match.scm")

;; scan for datatypes, definitions, etc..
;; and do source-level transformations that can't be handled by the macro system.

(define (transformer)

  (define counter 0)

  (define (go exp)
    (let ((expanded
	   (match (splice exp) with
	     (sexp:list ())    -> (sexp:list '())
	     (sexp:list (one)) -> (expand one)
	     (sexp:list exps)  -> (expand-body exps)
	     _ -> (error1 "unexpected s-expression in transformer:" exp)
	     )))
      (wrap-with-constructors (splice expanded))
      ))

  ;; similar to UNQUOTE-SPLICING.
  ;; (x y ... (%splice a b c) z)
  ;; -> (x y ... a b c z)

  (define (splice-list forms acc)
    (match forms with
      () -> (reverse acc)
      ;; crucial: don't eval %splice in macro definitions
      ((sexp:list ((sexp:symbol 'defmacro) . macro)) . tl)
      -> (splice-list tl (list:cons (sexp1 'defmacro macro) acc))
      ((sexp:list ((sexp:symbol '%splice) . forms0)) . forms1)
      -> (splice-list forms1 (foldr cons acc (reverse (map splice forms0))))
      (hd . tl)
      -> (splice-list tl (list:cons (splice hd) acc))
      ))

  (define splice
    (sexp:list forms)
    -> (sexp:list (splice-list forms '()))
    x -> x
    )

  (define (wrap-fix names inits body)
    (if (> (length names) 0)
        (sexp (sym 'fix)
              (list names)
              (list inits)
              body)
	body))

  (define wrap-begin
    ()    -> (error "empty body")
    (one) -> one
    exps  -> (sexp1 'begin exps))

  (define (wrap-definitions defs exps)
    (let ((names '())
          (inits '()))
      (for-each
       (lambda (:pair name init)
         (PUSH names (sexp:symbol name))
         (PUSH inits (expand init)))
       defs)
      (wrap-fix (reverse names) (reverse inits) (wrap-begin exps))))

  (define (expand-body exps)
    (let ((exps0 (scan-for-meta exps))
          (exps1 (find-declarations exps0))
          ((defs0 exps2) (collect-definitions '() '() exps1))
          ;; after macro expansion, we may have new declarations &
          ;; definitions, which may or may not be inserted with %slice.
          (exps3 (splice-list (map expand exps2) '()))
          (exps4 (find-declarations exps3))
          ((defs1 exps5) (collect-definitions defs0 '() exps4))
          (defs2 (map parse-define (reverse defs1))))
      (wrap-definitions defs2 exps5)))

  (define collect-definitions
    defs exps () -> (:tuple defs exps)
    defs exps (hd . tl)
    -> (match hd with
         (sexp:list ((sexp:symbol 'define) . body))
         ->   (collect-definitions (list:cons body defs) exps tl)
         _ -> (collect-definitions defs (list:cons hd exps) tl)
         ))

  (define (find-declarations exps)
    (define recur
      ()        acc -> (reverse acc)
      (hd . tl) acc
      -> (match hd with
	   (sexp:list ((sexp:symbol 'typealias) . dtl))
	   -> (begin (parse-typealias dtl) (recur tl acc))
	   (sexp:list ((sexp:symbol 'datatype) . dtl))
	   -> (begin (parse-datatype dtl) (recur tl acc))
	   (sexp:list ((sexp:symbol 'defmacro) . dtl))
	   -> (begin (parse-defmacro dtl) (recur tl acc))
	   _ -> (recur tl (list:cons hd acc))))
    (recur exps '()))

  ;; scan for forms that make compile-time decisions about how/what code to include.
  (define (scan-for-meta forms)
    (define loop
      acc () -> (reverse acc)
      acc ((sexp:list ((sexp:symbol '%backend) (sexp:symbol backend) . subs)) . tl)
      -> (if (eq? backend (backend->name the-context.options.backend))
             (loop (foldr cons acc (reverse (scan-for-meta subs))) tl)
             (loop acc tl))
      acc ((sexp:list ((sexp:symbol '%backend) (sexp:list backends) . subs)) . tl)
      -> (if (member? (sexp:symbol (backend->name the-context.options.backend)) backends sexp=?)
             (loop (foldr cons acc (reverse (scan-for-meta subs))) tl)
             (loop acc tl))
      acc ((sexp:list ((sexp:symbol 'include) (sexp:string path))) . tl)
      -> (loop (foldr cons acc (reverse (scan-for-meta (find-and-read-file path)))) tl)
      acc ((sexp:list ((sexp:symbol 'require-ffi) (sexp:list ((sexp:symbol 'quote) (sexp:symbol interface))))) . tl)
      -> (loop (foldr cons acc (reverse (autoffi interface))) tl)
      acc (hd . tl)
      -> (loop (list:cons hd acc) tl)
      )
    (loop '() forms))

  (define expand-field
    (field:t name exp) -> (field:t name (expand exp)))

;;   (define (expand exp)
;;     (print-string (format "expanding: " (repr exp) "\n"))
;;     (let ((r (expand* exp)))
;;       (print-string (format "         = " (repr r) "\n"))
;;       r))

  (define (expand exp)
    (match exp with
      (sexp:symbol _)	   -> exp
      (sexp:string _)	   -> exp
      (sexp:char _)	   -> exp
      (sexp:bool _)	   -> exp
      (sexp:int _)	   -> exp
      (sexp:undef)	   -> exp
      (sexp:cons _ _)	   -> exp
      (sexp:list l)	   -> (maybe-expand l)
      (sexp:vector rands)  -> (sexp:vector (map expand rands))
      (sexp:record fields) -> (sexp:record (map expand-field fields))
      (sexp:attr exp sym)  -> (sexp:attr (expand exp) sym)
      ))

  (define (maybe-expand l)
    (match l with
      () -> (sexp:list '())
      (rator . rands)
      -> (match rator with
	   (sexp:symbol sym)
	   -> (match (alist/lookup transform-table sym) with
		(maybe:yes fun)
                -> (fun rands)
		(maybe:no)
                -> (match (alist/lookup the-context.macros sym) with
                     (maybe:yes macro) -> (expand (macro.apply (sexp:list l) the-context.options.debugmacroexpansion))
                     (maybe:no)	       -> (sexp:list (list:cons rator (map expand rands)))))
	   ;; automagically insert the <self> argument
	   ;; (ob.o.method args0 ...) => (ob.o.method ob args0 ...)<commit_msg>more helpful handling of "empty body" error.<commit_after>;; -*- Mode: Irken -*-

(include "self/mbe.scm")
(include "self/types.scm")
(include "self/match.scm")

;; scan for datatypes, definitions, etc..
;; and do source-level transformations that can't be handled by the macro system.

(define (transformer)

  (define counter 0)

  (define (go exp)
    (let ((expanded
	   (match (splice exp) with
	     (sexp:list ())    -> (sexp:list '())
	     (sexp:list (one)) -> (expand one)
	     (sexp:list exps)  -> (expand-body exps)
	     _ -> (error1 "unexpected s-expression in transformer:" exp)
	     )))
      (wrap-with-constructors (splice expanded))
      ))

  ;; similar to UNQUOTE-SPLICING.
  ;; (x y ... (%splice a b c) z)
  ;; -> (x y ... a b c z)

  (define (splice-list forms acc)
    (match forms with
      () -> (reverse acc)
      ;; crucial: don't eval %splice in macro definitions
      ((sexp:list ((sexp:symbol 'defmacro) . macro)) . tl)
      -> (splice-list tl (list:cons (sexp1 'defmacro macro) acc))
      ((sexp:list ((sexp:symbol '%splice) . forms0)) . forms1)
      -> (splice-list forms1 (foldr cons acc (reverse (map splice forms0))))
      (hd . tl)
      -> (splice-list tl (list:cons (splice hd) acc))
      ))

  (define splice
    (sexp:list forms)
    -> (sexp:list (splice-list forms '()))
    x -> x
    )

  (define (wrap-fix names inits body)
    (if (> (length names) 0)
        (sexp (sym 'fix)
              (list names)
              (list inits)
              body)
	body))

  (define wrap-begin
    ()    -> (raise (:Transform/Error "empty body"))
    (one) -> one
    exps  -> (sexp1 'begin exps))

  (define (wrap-definitions defs exps)
    (let ((names '())
          (inits '()))
      (for-each
       (lambda (:pair name init)
         (PUSH names (sexp:symbol name))
         (PUSH inits (expand init)))
       defs)
      (try
       (wrap-fix (reverse names) (reverse inits) (wrap-begin exps))
       except (:Transform/Error msg)
       -> (raise (:Transform/Error msg))
       )
      ))

  (define (expand-body exps)
    (let ((exps0 (scan-for-meta exps))
          (exps1 (find-declarations exps0))
          ((defs0 exps2) (collect-definitions '() '() exps1))
          ;; after macro expansion, we may have new declarations &
          ;; definitions, which may or may not be inserted with %slice.
          (exps3 (splice-list (map expand exps2) '()))
          (exps4 (find-declarations exps3))
          ((defs1 exps5) (collect-definitions defs0 '() exps4))
          (defs2 (map parse-define (reverse defs1))))
      (wrap-definitions defs2 exps5)))

  (define collect-definitions
    defs exps () -> (:tuple defs exps)
    defs exps (hd . tl)
    -> (match hd with
         (sexp:list ((sexp:symbol 'define) . body))
         ->   (collect-definitions (list:cons body defs) exps tl)
         _ -> (collect-definitions defs (list:cons hd exps) tl)
         ))

  (define (find-declarations exps)
    (define recur
      ()        acc -> (reverse acc)
      (hd . tl) acc
      -> (match hd with
	   (sexp:list ((sexp:symbol 'typealias) . dtl))
	   -> (begin (parse-typealias dtl) (recur tl acc))
	   (sexp:list ((sexp:symbol 'datatype) . dtl))
	   -> (begin (parse-datatype dtl) (recur tl acc))
	   (sexp:list ((sexp:symbol 'defmacro) . dtl))
	   -> (begin (parse-defmacro dtl) (recur tl acc))
	   _ -> (recur tl (list:cons hd acc))))
    (recur exps '()))

  ;; scan for forms that make compile-time decisions about how/what code to include.
  (define (scan-for-meta forms)
    (define loop
      acc () -> (reverse acc)
      acc ((sexp:list ((sexp:symbol '%backend) (sexp:symbol backend) . subs)) . tl)
      -> (if (eq? backend (backend->name the-context.options.backend))
             (loop (foldr cons acc (reverse (scan-for-meta subs))) tl)
             (loop acc tl))
      acc ((sexp:list ((sexp:symbol '%backend) (sexp:list backends) . subs)) . tl)
      -> (if (member? (sexp:symbol (backend->name the-context.options.backend)) backends sexp=?)
             (loop (foldr cons acc (reverse (scan-for-meta subs))) tl)
             (loop acc tl))
      acc ((sexp:list ((sexp:symbol 'include) (sexp:string path))) . tl)
      -> (loop (foldr cons acc (reverse (scan-for-meta (find-and-read-file path)))) tl)
      acc ((sexp:list ((sexp:symbol 'require-ffi) (sexp:list ((sexp:symbol 'quote) (sexp:symbol interface))))) . tl)
      -> (loop (foldr cons acc (reverse (autoffi interface))) tl)
      acc (hd . tl)
      -> (loop (list:cons hd acc) tl)
      )
    (loop '() forms))

  (define expand-field
    (field:t name exp) -> (field:t name (expand exp)))

  (define (expand* exp)
    (match exp with
      (sexp:symbol _)	   -> exp
      (sexp:string _)	   -> exp
      (sexp:char _)	   -> exp
      (sexp:bool _)	   -> exp
      (sexp:int _)	   -> exp
      (sexp:undef)	   -> exp
      (sexp:cons _ _)	   -> exp
      (sexp:list l)	   -> (maybe-expand l)
      (sexp:vector rands)  -> (sexp:vector (map expand rands))
      (sexp:record fields) -> (sexp:record (map expand-field fields))
      (sexp:attr exp sym)  -> (sexp:attr (expand exp) sym)
      ))

  (define (expand exp)
    (try
     (expand* exp)
     except (:Transform/Error msg)
     -> (begin
          (printf "error expanding expression: " (repr exp) "\n")
          (raise (:Transform/Error msg)))
     ))

  (define (maybe-expand l)
    (match l with
      () -> (sexp:list '())
      (rator . rands)
      -> (match rator with
	   (sexp:symbol sym)
	   -> (match (alist/lookup transform-table sym) with
		(maybe:yes fun)
                -> (fun rands)
		(maybe:no)
                -> (match (alist/lookup the-context.macros sym) with
                     (maybe:yes macro) -> (expand (macro.apply (sexp:list l) the-context.options.debugmacroexpansion))
                     (maybe:no)	       -> (sexp:list (list:cons rator (map expand rands)))))
	   ;; automagically insert the <self> argument
	   ;; (ob.o.method args0 ...) => (ob.o.method ob args0 ...)
{'fraction_non_alphanumeric': 0.16245029190286828, 'fraction_numerical': 0.0049073525678991455, 'mean_word_length': 2.2742382271468142, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 113, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3782436', 'n_tokens_mistral': 4202, 'n_tokens_neox': 4061, 'n_words': 1141}