Skip to content
This repository
Browse code

trying to get cs19's signatures into the teaching language

  • Loading branch information...
commit f11553c00841404297e8e436a838b78772943123 1 parent 6eb21a4
Danny Yoo authored

Showing 1 changed file with 336 additions and 0 deletions. Show diff stats Hide diff stats

  1. +336 0 lang/private/sigs.rkt
336 lang/private/sigs.rkt
... ... @@ -0,0 +1,336 @@
  1 +#lang s-exp "../base.rkt"
  2 +
  3 +(require [for-syntax syntax/parse]
  4 + [for-syntax syntax/struct]
  5 + [for-syntax racket])
  6 +
  7 +
  8 +
  9 +(provide define: lambda: define-struct: and: or: not:)
  10 +
  11 +(define-for-syntax (parse-sig stx)
  12 + (syntax-case stx (->)
  13 + [(A ... -> R)
  14 + (with-syntax ([(A ...) (map parse-sig (syntax->list #'(A ...)))]
  15 + [R (parse-sig #'R)])
  16 + #'(proc: (A ... -> R)))]
  17 + [_ stx]))
  18 +
  19 +(define-for-syntax (parse-sigs stxs)
  20 + (map parse-sig (syntax->list stxs)))
  21 +
  22 +(define-syntax (define-struct: stx)
  23 + (syntax-case stx (:)
  24 + [(_ sn ([f : S] ...))
  25 + (with-syntax ([(names ...)
  26 + (build-struct-names #'sn
  27 + (syntax->list #'(f ...))
  28 + #f #f)]
  29 + [term stx]
  30 + [(S ...) (parse-sigs #'(S ...))])
  31 + (with-syntax ([sig-name (datum->syntax #'sn
  32 + (string->symbol
  33 + (string-append
  34 + (symbol->string
  35 + (syntax->datum #'sn))
  36 + "$")))]
  37 + [cnstr (syntax-case #'(names ...) ()
  38 + [(struct:name-id constructor misc ...)
  39 + #'constructor])]
  40 + [(_sid _ctr _id? setters ...)
  41 + (build-struct-names #'sn
  42 + (syntax->list #'(f ...))
  43 + #t #f)]
  44 + [pred (syntax-case #'(names ...) ()
  45 + [(struct:name-id const predicate misc ...)
  46 + #'predicate])])
  47 + #'(begin
  48 + (define-values (names ...)
  49 + (let ()
  50 + (begin
  51 + (define-struct sn (f ...) #:transparent #:mutable)
  52 + (let ([cnstr
  53 + (lambda (f ...)
  54 + (let ([wrapped-args
  55 + (let loop ([sigs (list S ... )]
  56 + [args (list f ...)]
  57 + [sig-srcs (syntax->list #'(S ...))]
  58 + [n 1])
  59 + (if (empty? sigs)
  60 + empty
  61 + (cons (wrap (first sigs)
  62 + (first args)
  63 + )
  64 + (loop (rest sigs)
  65 + (rest args)
  66 + (rest sig-srcs)
  67 + (add1 n)))))])
  68 + (apply cnstr wrapped-args)))]
  69 + [setters
  70 + (lambda (struct-inst new-val)
  71 + (setters struct-inst (wrap S new-val)))]
  72 + ...)
  73 + (values names ...)))))
  74 + ;; This could be a define below, but it's a define-values
  75 + ;; due to a bug in ISL's local. See users@racket-lang.org
  76 + ;; thread, 2011-09-03, "splicing into local". Should not
  77 + ;; be necessary with next release.
  78 + (define-values (sig-name)
  79 + (first-order-sig pred)))))]))
  80 +
  81 +(define (not-sig-error src)
  82 + (error 'signature-violation "not a valid signature: ~e" src))
  83 +
  84 +(define (wrap sig val)
  85 + (if (signature? sig)
  86 + ((signature-wrapper sig) val)
  87 + (not-sig-error)))
  88 +
  89 +(provide Number$ String$ Char$ Boolean$ Any$ Sig: Listof: Vectorof:)
  90 +
  91 +(define-struct signature (pred wrapper ho?))
  92 +
  93 +(define-syntax (Listof: stx)
  94 + (syntax-case stx ()
  95 + [(_ S)
  96 + (with-syntax ([S (parse-sig #'S)]
  97 + [term stx])
  98 + #'(let ([s S]
  99 + [sig-src #'S]
  100 + [term-src #'term])
  101 + (if (signature? s)
  102 + (if (signature-ho? s)
  103 + (make-signature list?
  104 + (lambda (v)
  105 + (map (lambda (e) (wrap s e)) v))
  106 + true
  107 + term-src)
  108 + (let ([pred (lambda (v)
  109 + (and (list? v)
  110 + (andmap (signature-pred s) v)))])
  111 + (make-signature pred
  112 + (lambda (v)
  113 + (if (pred v)
  114 + v
  115 + (if (list? v)
  116 + (raise-syntax-error
  117 + 'signature-violation
  118 + "not an appropriate list"
  119 + v
  120 + #f
  121 + (list sig-src))
  122 + (raise-syntax-error
  123 + 'signature-violation
  124 + "not a list"
  125 + v
  126 + #f
  127 + (list term-src)))))
  128 + false
  129 + term-src)))
  130 + (not-sig-error sig-src))))]))
  131 +
  132 +(define-syntax (Vectorof: stx)
  133 + (syntax-case stx ()
  134 + [(_ S)
  135 + (with-syntax ([S (parse-sig #'S)]
  136 + [term stx])
  137 + #'(let ([s S]
  138 + [sig-src #'S]
  139 + [term-src #'term])
  140 + (if (signature? s)
  141 + (if (signature-ho? s)
  142 + (make-signature vector?
  143 + (lambda (v)
  144 + (list->vector
  145 + (map (lambda (e) (wrap s e))
  146 + (vector->list v))))
  147 + true
  148 + term-src)
  149 + (let ([pred (lambda (v)
  150 + (and (vector? v)
  151 + (andmap (signature-pred s)
  152 + (vector->list v))))])
  153 + (make-signature pred
  154 + (lambda (v)
  155 + (if (pred v)
  156 + v
  157 + (if (vector? v)
  158 + (raise-syntax-error
  159 + 'signature-violation
  160 + "not an appropriate vector"
  161 + v
  162 + #f
  163 + (list sig-src))
  164 + (raise-syntax-error
  165 + 'signature-violation
  166 + "not a vector"
  167 + v
  168 + #f
  169 + (list term-src)))))
  170 + false
  171 + term-src)))
  172 + (not-sig-error sig-src))))]))
  173 +
  174 +(define (first-order-sig pred?)
  175 + (make-signature pred?
  176 + (lambda (v)
  177 + (if (pred? v)
  178 + v
  179 + (error
  180 + 'signature-violation
  181 + (format "value ~a failed the signature" v)
  182 + #;#f
  183 + #;#f
  184 + #;(list term-src))))
  185 + #f))
  186 +
  187 +(define-syntax (Sig: stx)
  188 + (syntax-case stx ()
  189 + [(_ S)
  190 + (with-syntax ([Sp (parse-sig #'S)]
  191 + [term stx])
  192 + (if (eq? #'Sp #'S) ;; currently means S is NOT (... -> ...)
  193 + #'(first-order-sig S)
  194 + #'Sp))]))
  195 +
  196 +(define-syntax (Number$ stx)
  197 + (syntax-case stx (Number$)
  198 + [Number$
  199 + (with-syntax ([term stx])
  200 + #'(first-order-sig number?))]))
  201 +
  202 +(define-syntax (String$ stx)
  203 + (syntax-case stx (String$)
  204 + [String$
  205 + (with-syntax ([term stx])
  206 + #'(first-order-sig string?))]))
  207 +
  208 +(define-syntax (Char$ stx)
  209 + (syntax-case stx (char$)
  210 + [Char$
  211 + (with-syntax ([term stx])
  212 + #'(first-order-sig char?))]))
  213 +
  214 +(define-syntax (Boolean$ stx)
  215 + (syntax-case stx (Boolean$)
  216 + [Boolean$
  217 + (with-syntax ([term stx])
  218 + #'(first-order-sig boolean?))]))
  219 +
  220 +(define-syntax (Any$ stx)
  221 + (syntax-case stx (Any$)
  222 + [Any$
  223 + (with-syntax ([term stx])
  224 + #'(first-order-sig (lambda (_) true)))]))
  225 +
  226 +;; proc: is for internal use only.
  227 +;; Stand-alone procedural signatures are defined using Sig:; e.g.,
  228 +;; (define n->n (Sig: (Number$ -> Number$)))
  229 +;; In all other cases, the macros invoke parse-sig, which takes care of
  230 +;; automatically wrapping (proc: ...) around procedure signatures.
  231 +(define-syntax (proc: stx)
  232 + (syntax-case stx (->)
  233 + [(_ (A ... -> R))
  234 + (with-syntax ([(args ...) (generate-temporaries #'(A ...))]
  235 + [(A ...) (parse-sigs #'(A ...))]
  236 + [R (parse-sig #'R)]
  237 + [term stx])
  238 + #'(make-signature
  239 + procedure?
  240 + (lambda (v)
  241 + (if (procedure? v)
  242 + (lambda (args ...)
  243 + (wrap R (v (wrap A args #'A) ...)))
  244 + (raise-syntax-error
  245 + 'signature-violation
  246 + "not a procedure"
  247 + v
  248 + #f
  249 + (list #'term))))
  250 + true
  251 + #'term))]))
  252 +
  253 +(define-syntax (define: stx)
  254 + (syntax-case stx (: ->)
  255 + [(_ id : S exp)
  256 + (identifier? #'id)
  257 + (with-syntax ([S (parse-sig #'S)])
  258 + #'(define id (wrap S exp)))]
  259 + [(_ (f [a : Sa] ...) -> Sr exp)
  260 + (with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))]
  261 + [Sr (parse-sig #'Sr)])
  262 + #'(define f (lambda: ([a : Sa] ...) -> Sr exp)))]))
  263 +
  264 +(define-syntax (lambda: stx)
  265 + (syntax-case stx (: ->)
  266 + [(_ ([a : Sa] ...) -> Sr exp)
  267 + (with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))]
  268 + [Sr (parse-sig #'Sr)])
  269 + #'(lambda (a ...)
  270 + (let ([a (wrap Sa a)] ...)
  271 + (wrap Sr exp))))]))
  272 +
  273 +(define-syntax (or: stx)
  274 + (syntax-case stx ()
  275 + [(_ S ...)
  276 + (with-syntax ([(S ...) (parse-sigs #'(S ...))]
  277 + [term stx])
  278 + #'(first-order-sig
  279 + (lambda (x)
  280 + (let loop ([sigs (list S ...)]
  281 + [sig-srcs (syntax->list #'(S ...))])
  282 + (if (empty? sigs)
  283 + false
  284 + (let ([s (first sigs)])
  285 + (if (signature? s)
  286 + (if (signature-ho? s)
  287 + (raise-syntax-error
  288 + 'signature-violation
  289 + "or: cannot combine higher-order signature"
  290 + #'term
  291 + #f
  292 + (list #;(signature-src s)))
  293 + (or ((signature-pred s) x)
  294 + (loop (rest sigs) (rest sig-srcs))))
  295 + (not-sig-error (first sig-srcs)))))))))]))
  296 +
  297 +(define-syntax (and: stx)
  298 + (syntax-case stx ()
  299 + [(_ S ...)
  300 + (with-syntax ([(S ...) (parse-sigs #'(S ...))]
  301 + [term stx])
  302 + #'(first-order-sig
  303 + (lambda (x)
  304 + (let loop ([sigs (list S ...)]
  305 + [sig-srcs (syntax->list #'(S ...))])
  306 + (if (empty? sigs)
  307 + true
  308 + (let ([s (first sigs)])
  309 + (if (signature? s)
  310 + (if (signature-ho? s)
  311 + (raise-syntax-error
  312 + 'signature-violation
  313 + "and: cannot combine higher-order signature"
  314 + #'term
  315 + #f
  316 + (list #;(signature-src s)))
  317 + (and ((signature-pred s) x)
  318 + (loop (rest sigs) (rest sig-srcs))))
  319 + (not-sig-error (first sig-srcs)))))))))]))
  320 +
  321 +(define-syntax (not: stx)
  322 + (syntax-case stx ()
  323 + [(_ S)
  324 + (with-syntax ([S (parse-sig #'S)]
  325 + [term stx])
  326 + #'(let ([s S]
  327 + [sig-src #'S]
  328 + [term-src #'term])
  329 + (if (signature? s)
  330 + (if (signature-ho? s)
  331 + (raise-syntax-error
  332 + 'signature-violation
  333 + "not: cannot negate higher-order signature"
  334 + #'term)
  335 + (first-order-sig (lambda (x) (not ((signature-pred s) x)))))
  336 + (not-sig-error sig-src))))]))

0 comments on commit f11553c

Please sign in to comment.
Something went wrong with that request. Please try again.