www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README

pre.rkt (2963B)

      1 #lang racket/base
      2 
      3 (require syntax/parse
      4          (for-syntax racket/base
      5                      syntax/parse
      6                      racket/syntax
      7                      phc-toolkit/untyped)
      8          "parameters.rkt"
      9          "no-order.rkt"
     10          "nop.rkt")
     11 
     12 (provide ~pre-check
     13          ~pre-fail
     14          ~named-seq
     15          ~maybe/empty)
     16 
     17 (define-eh-mixin-expander ~pre-check
     18   (λ (stx)
     19     (syntax-case stx ()
     20       [(_ pat post)
     21        (begin (eh-pre-accumulate! '~pre-check #'post)
     22               #'pat)]
     23       [(_ post)
     24        (begin (eh-pre-accumulate! '~pre-check #'post)
     25               #'(~nop))])))
     26 
     27 (define-for-syntax (pre-fail stx)
     28   (syntax-case stx ()
     29     [(_ message #:when condition)
     30      (let ()
     31        (define/with-syntax clause-present (get-new-clause!))
     32        (eh-pre-accumulate! '~pre-fail
     33                            #`(~fail #:when (and (attribute clause-present)
     34                                                 condition)
     35                                     message))
     36        #'(~bind [clause-present #t]))]
     37     [(self #:when condition message)
     38      (pre-fail #'(self message #:when condition))]
     39     [(self message #:unless unless-condition)
     40      (pre-fail #'(self message #:when (not unless-condition)))]
     41     [(self #:unless unless-condition message)
     42      (pre-fail #'(self message #:when (not unless-condition)))]))
     43 
     44 (define-eh-mixin-expander ~pre-fail pre-fail)
     45 
     46 ;; TODO: fixme: should happen before the other pre operations
     47 (define-eh-mixin-expander ~named-seq
     48   (λ (stx)
     49     (syntax-case stx ()
     50       [(_ id . pats)
     51        (identifier? #'id)
     52        (let ()
     53          (define/with-syntax clause-present (get-new-clause!))
     54          (define/with-syntax clause (get-new-clause!))
     55          (eh-first-accumulate! '~named-seq
     56                                #'(~bind [(id 1) (if (attribute clause-present)
     57                                                     (attribute clause)
     58                                                     (list))]))
     59          #'(~and (~bind [clause-present #t])
     60                  (~seq clause (... ...))
     61                  (~seq . pats)))])))
     62 
     63 
     64 ;; TODO: fixme: should happen before the other pre operations
     65 (define-eh-mixin-expander ~maybe/empty
     66   (syntax-parser
     67     [(_ {~and pat {~not #:name}} …
     68         {~optional {~seq #:name name}})
     69      (let ()
     70        (define/with-syntax clause-present (get-new-clause!))
     71        (define/with-syntax (expanded-pat …)
     72          ;; let the ~post, ~global etc. within pat … be recognized
     73          (expand-all-eh-mixin-expanders #'(pat …)))
     74        (eh-first-accumulate! '~maybe/empty
     75                              #'(~parse (expanded-pat …)
     76                                        (if (attribute clause)
     77                                            #'(clause (... ...))
     78                                            #'())))
     79        #`{~optional {~and {~bind [clause-present #t]}
     80                           {~seq clause (... ...)}}
     81                     #,@(when-attr name #'(#:name name))})]))