#lang racket

(provide ;typed/untyped
 require-typed/untyped-typed
 require-typed/untyped
 require/provide-typed/untyped
 define-typed/untyped-modules
 define-typed/untyped-light-modules
 define-typed/untyped-test-module
 if-typed
 when-typed
 when-untyped)

(require typed/untyped-utils
         racket/require-syntax
         (for-syntax syntax/parse
                     racket/syntax
                     syntax/stx
                     syntax/strip-context))

(module m-typed typed/racket
  (provide (rename-out [require tr:require]
                       [provide tr:provide])
           ;typed/untyped
           #;require-typed/untyped)
  
  #;(require (for-syntax syntax/parse
                         racket/syntax
                         syntax/stx
                         syntax/strip-context)
             racket/require-syntax)
  
  
  
  #;(define-syntax (require-typed/untyped stx)
      (syntax-case stx ()
        [(_ m)
         (let ()
           (define/with-syntax sb (datum->syntax #'m 'submod #'m #'m))
           (define/with-syntax ty (datum->syntax #'m 'typed #'m #'m))
           #'(require (sb m ty)))])))

#;(require 'm-typed)

;; require
(define-syntax (require-typed/untyped-typed stx)
  (syntax-parse stx
    [(_ . (~and ms (m ...)))
     (replace-context #'ms #'(require (submod m typed) ...))]))

#;(define-require-syntax (typed/untyped-typed stx)
    (syntax-case stx ()
      [(_ m) (replace-context stx #'(submod m typed))]))

#;(define-require-syntax (typed/untyped-untyped stx)
    (syntax-case stx ()
      [(_ m) (replace-context stx #'(submod m untyped))]))

(define-syntax (require-typed/untyped-untyped stx)
  (syntax-parse stx
    [(_ . (~and ms (m ...)))
     (replace-context #'ms #'(require (submod m untyped) ...))]))

(define-typed/untyped-identifier require-typed/untyped
  require-typed/untyped-typed
  require-typed/untyped-untyped)

#;(define-typed/untyped-identifier typed/untyped
    typed/untyped-typed
    typed/untyped-untyped)

;; require/provide
;; TODO: make a require expander instead.
(define-syntax (require/provide-typed/untyped-typed stx)
  (syntax-parse stx
    [(_ . (~and ms (m ...)))
     (replace-context #'ms
                      #'(begin
                          (require (submod m typed) ...)
                          (provide (all-from-out (submod m typed) ...))))]))

(define-syntax (require/provide-typed/untyped-untyped stx)
  (syntax-parse stx
    [(_ . (~and ms (m ...)))
     (replace-context #'ms
                      #'(begin
                          (require (submod m untyped) ...)
                          (provide (all-from-out (submod m untyped) ...))))]))

(define-typed/untyped-identifier require/provide-typed/untyped
  require/provide-typed/untyped-typed
  require/provide-typed/untyped-untyped)

#|
(module mt typed/racket
  (define-syntax-rule (require/provide-typed/untyped m)
    (require m))
  (provide require/provide-typed/untyped))
(require 'mt)
|#

;; define-typed/untyped-modules
(begin
  (define-syntax (define-typed/untyped-modules stx)
    (syntax-parse stx
      [(def-t/u-mod (~optional (~and no-test #:no-test))
         (~optional (~and untyped-first #:untyped-first)) . body)
       (define (ds sym) (datum->syntax #'def-t/u-mod sym #'def-t/u-mod))
       (define/with-syntax module-typed
         #`(module #,(ds 'typed) #,(ds 'typed/racket)
             . body))
       (define/with-syntax module-untyped
         #`(module #,(ds 'untyped) #,(ds 'typed/racket/no-check)
             #,(ds '(require (for-syntax racket/base)))
             . body))
       #`(begin
           #,(if (attribute untyped-first) #'module-untyped #'module-typed)
           #,(if (attribute untyped-first) #'module-typed #'module-untyped)
           #,@(if (attribute no-test)
                  #'()
                  #`((module #,(ds 'test) #,(ds 'typed/racket)
                       #,(ds `(require (submod ".." typed test)))
                       #,(ds `(require (submod ".." untyped test))))))
           #,(ds '(require 'typed))
           #,(ds '(provide (all-from-out 'typed))))]))

  (define-syntax (define-typed/untyped-light-modules stx)
    (syntax-parse stx
      [(def-t/u-mod (~optional (~and no-test #:no-test))
         (~optional (~and untyped-first #:untyped-first)) . body)
       (define (ds sym) (datum->syntax #'def-t/u-mod sym #'def-t/u-mod))
       (define/with-syntax module-typed
         #`(module #,(ds 'typed) #,(ds 'typed/racket)
             . body))
       (define/with-syntax module-untyped
         #`(module #,(ds 'untyped) #,(ds 'racket/base)
             #,(ds '(require (for-syntax racket/base)))
             . body))
       #`(begin
           #,(if (attribute untyped-first) #'module-untyped #'module-typed)
           #,(if (attribute untyped-first) #'module-typed #'module-untyped)
           #,@(if (attribute no-test)
                  #'()
                  #`((module #,(ds 'test) #,(ds 'typed/racket)
                       #,(ds `(require (submod ".." typed test)))
                       #,(ds `(require (submod ".." untyped test))))))
           #,(ds '(require 'typed))
           #,(ds '(provide (all-from-out 'typed))))]))

  (define-syntax (define-typed/untyped-test-module stx)
    (syntax-parse stx
      [(def-t/u-t-mod (~optional (~and untyped-first #:untyped-first)) . body)
       (define (ds sym) (datum->syntax #'def-t/u-t-mod sym #'def-t/u-t-mod))
       (define/with-syntax module-typed
         #`(module #,(ds 'typed-test) #,(ds 'typed/racket)
             #,(ds '(require typed/rackunit
                             "../typed-untyped.rkt"))
             . body))
       (define/with-syntax module-untyped
         #`(module #,(ds 'untyped-test) #,(ds 'typed/racket/no-check)
             #,(ds '(require (for-syntax racket/base)
                             rackunit
                             "../typed-untyped.rkt"))
             . body))
       #`(begin
           #,(if (attribute untyped-first) #'module-untyped #'module-typed)
           #,(if (attribute untyped-first) #'module-typed #'module-untyped)
           (module #,(ds 'test) #,(ds 'typed/racket)
             #,(ds `(require (submod ".." typed-test)))
             #,(ds `(require (submod ".." untyped-test))))
           #,(ds '(require 'typed-test))
           #,(ds '(provide (all-from-out 'typed-test))))]))
  
  #| ;; test: should work in no-check but not in typed:
  (define-typed/untyped-modules moo
    (: foo One)
    (define foo 2))
  |#)

;; if-typed
(define-syntax-rule (if-typed-typed t u) t)
(define-syntax-rule (if-typed-untyped t u) u)
(define-typed/untyped-identifier if-typed
  if-typed-typed
  if-typed-untyped)

;; when-typed and when-untyped
(define-syntax-rule (when-typed . t) (if-typed (begin . t) (begin)))
(define-syntax-rule (when-untyped . t) (if-typed (begin) (begin . t)))

;; typed/untyped-prefix
(begin
  (define-syntax-rule (typed/untyped-prefix [typed-prefix ...]
                                            [untyped-prefix ...]
                                            . rest)
    (if-typed (typed-prefix ... . rest)
              (untyped-prefix ... . rest)))
  #|
  ;; test: should work in no-check but not in typed:
  (typed/untyped-prefix
   [module moo2 typed/racket]
   [module moo2 typed/racket/no-check]
   (: foo One)
   (define foo 2))
  |#)

;; define-modules
(begin
  ;; define-modules
  (define-syntax define-modules
    (syntax-rules (no-submodule)
      [(_ ([no-submodule] [name lang] ...) . body)
       (begin (begin . body)
              (module name lang . body) ...)]
      [(_ ([name lang] ...) . body)
       (begin (module name lang . body) ...)]))
  
  #|
  ;; TODO: tests: test with a macro and check that we can use it in untyped.
  ;; TODO: tests: test with two mini-languages with different semantics for some
  ;; function.
  (define-modules ([foo typed/racket] [foo-untyped typed/racket/no-check])
    (provide x)
    (: x (→ Syntax Syntax))
    (define (x s) s))
  
  (module test racket
    (require (submod ".." foo-untyped))
    (x #'a))
  |#)