; SPDX-License-Identifier: LGPL-3.0-or-later
; Copyright (C) 2010-2021 Tony Garnock-Jones <tonygarnockjones@gmail.com>

#lang racket/base

(provide (rename-out [module-begin #%module-begin])
         activate
         require/activate
         current-ground-dataspace
         current-activated-modules
         begin-for-declarations ;; TODO: this seems like a horrible hack
	 (except-out (all-from-out racket/base) #%module-begin sleep)
	 (all-from-out racket/match)
         (all-from-out "main.rkt")
	 (for-syntax (all-from-out racket/base)))

(require racket/match)
(require "main.rkt")
(require (for-syntax racket/base syntax/kerncase))

(define-syntax (activate stx)
  (syntax-case stx ()
    [(_ module-path ...)
     (syntax/loc stx
       (begin
         (let ()
           (local-require (submod module-path syndicate-main))
           (activate!))
         ...))]))

(define-syntax (require/activate stx)
  (syntax-case stx ()
    [(_ module-path ...)
     (syntax/loc stx
       (begin
         (require module-path ...)
         (activate module-path ...)))]))

(define-syntax-rule (begin-for-declarations decl ...)
  (begin decl ...))

(define current-ground-dataspace (make-parameter #f))
(define current-activated-modules (make-parameter #f))

(define-syntax (module-begin stx)
  (unless (eq? (syntax-local-context) 'module-begin)
    (raise-syntax-error #f "allowed only around a module body" stx))
  (syntax-case stx ()
    [(_ forms ...)
     (let ()

       (define (accumulate-actions activation-forms final-forms forms)
         (cond
           [(null? forms)
            (define final-stx
              #`(#%module-begin
                 ;----------------------------------------
                 ; The final module has three pieces:
                 ; - a `syndicate-main` submodule, for activation
                 ; - a `main` submodule, for programs
                 ; - actual definitions, for everything else.
                 ; The `main` submodule is split into two pieces,
                 ; in order to initialise defaults that can then
                 ; be overridden by the module being compiled.

                 (module+ syndicate-main
                   (provide activate!* activate!)
                   (define (activate!*)
                     #,@(reverse activation-forms)
                     (void))
                   (define (activate!)
                     (when (not (hash-has-key? (current-activated-modules) activate!*))
                       (hash-set! (current-activated-modules) activate!* #t)
                       (activate!*))))

                 (module+ main (current-ground-dataspace run-ground))

                 #,@(reverse final-forms)

                 (module+ main
                   (require (submod ".." syndicate-main))
                   (parameterize ((current-activated-modules (make-hasheq)))
                     ((current-ground-dataspace) activate!)))

                 ;----------------------------------------
                 ))
            ;;(pretty-print (syntax->datum final-stx))
            final-stx]

           [else
            (syntax-case (local-expand (car forms)
                                       'module
                                       (append (list #'module+
                                                     #'begin-for-declarations)
                                               (kernel-form-identifier-list))) ()
              [(head rest ...)
               (cond
                 [(free-identifier=? #'head #'begin)
                  (accumulate-actions activation-forms
                                      final-forms
                                      (append (syntax->list #'(rest ...)) (cdr forms)))]
                 [(ormap (lambda (i) (free-identifier=? #'head i))
                         (syntax->list #'(define-values define-syntaxes begin-for-syntax
                                           module module* module+
                                           #%module-begin
                                           #%require #%provide
                                           begin-for-declarations)))
                  (accumulate-actions activation-forms
                                      (cons (car forms) final-forms)
                                      (cdr forms))]
                 [else
                  (accumulate-action (car forms) activation-forms final-forms (cdr forms))])]
              [non-pair-syntax
               (accumulate-action (car forms) activation-forms final-forms (cdr forms))])]))

       (define (accumulate-action action activation-forms final-forms remaining-forms)
	 (accumulate-actions (cons action activation-forms) final-forms remaining-forms))

       (accumulate-actions '() '() (syntax->list #'(forms ...))))]))