www

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

fabul-utils.rkt (2184B)

      1 #lang racket
      2 (require syntax/parse
      3          turnstile/mode
      4          (for-syntax syntax/parse syntax/stx racket/syntax)
      5          (for-template macrotypes/typecheck
      6                        (only-in "lin.rkt"
      7                                 linear-mode?
      8                                 make-empty-linear-mode)))
      9 
     10 (provide current-language
     11          language-name
     12          type-converter
     13          unrestricted-mode?
     14          make-empty-unrestricted-mode
     15          L->U
     16          U->L
     17          )
     18 
     19 (struct unrestricted-mode mode (lin-mode))
     20 
     21 (define (make-empty-unrestricted-mode)
     22   (unrestricted-mode void void (make-empty-linear-mode)))
     23 
     24 (define (L->U lin-mode)
     25   (unrestricted-mode void void lin-mode))
     26 
     27 (define (U->L un-mode)
     28   (unrestricted-mode-lin-mode un-mode))
     29 
     30 
     31 (define (current-language)
     32   (if (linear-mode? (current-mode))
     33       'L
     34       'U))
     35 
     36 (define (language-name [lang (current-language)])
     37   (case lang
     38     [(L) "linear"]
     39     [(U) "unrestricted"]))
     40 
     41 
     42 ; generates function to convert type into language
     43 ; e.g.   (type-converter [ <clauses> ... ]
     44 ;                        [ A  =>  B ]
     45 ;                        [ C  =>  D ]
     46 ;                        <fail-function>)
     47 (define-syntax type-converter
     48   (syntax-parser
     49     #:datum-literals (=>)
     50     [(_ (stxparse ...)
     51         ([from:id => to:id] ...)
     52         fail-fn)
     53      #:with self (generate-temporary)
     54      #:with [(lhs rhs) ...] #'[(from to) ... (to to) ...]
     55      #:with [tycon-clause ...]
     56      (stx-map (λ (tycon/l tycon/r)
     57                 (with-syntax ([patn (format-id tycon/l "~~~a" tycon/l)]
     58                               [ctor tycon/r]
     59                               [t (generate-temporary)]
     60                               [s (generate-temporary)])
     61                   #'[(patn t (... ...))
     62                      #:with [s (... ...)] (stx-map self #'[t (... ...)])
     63                      (syntax/loc this-syntax (ctor s (... ...)))]))
     64               #'[lhs ...]
     65               #'[rhs ...])
     66      #'(letrec ([self (syntax-parser
     67                         stxparse ...
     68                         tycon-clause ...
     69                         [(~not (~Any _ . _)) this-syntax]
     70                         [_ (fail-fn this-syntax)])])
     71          self)]))