Skip to content

Automated Resyntax fixes #1410

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 1 commit into from
Closed

Automated Resyntax fixes #1410

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
47 changes: 16 additions & 31 deletions typed-racket-lib/typed-racket/types/base-abbrev.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -102,15 +102,11 @@
(foldr -pair b l))

;; Recursive types
(define-syntax -v
(syntax-rules ()
[(_ x) (make-F 'x)]))
(define-syntax-rule (-v x)
(make-F 'x))

(define-syntax -mu
(syntax-rules ()
[(_ var ty)
(let ([var (-v var)])
(make-Mu 'var ty))]))
(define-syntax-rule (-mu var ty)
(let ([var (-v var)]) (make-Mu 'var ty)))

;; Results
(define/cond-contract (-result t [pset -tt-propset] [o -empty-obj])
Expand Down Expand Up @@ -493,31 +489,20 @@


;; Convenient syntax for polymorphic types
(define-syntax -poly
(syntax-rules ()
[(_ (vars ...) ty)
(let ([vars (-v vars)] ...)
(make-Poly (list 'vars ...) ty))]))

(define-syntax -polydots
(syntax-rules ()
[(_ (vars ... dotted) ty)
(let ([dotted (-v dotted)]
[vars (-v vars)] ...)
(make-PolyDots (list 'vars ... 'dotted) ty))]))

(define-syntax -polyrow
(syntax-rules ()
[(_ (var) consts ty)
(let ([var (-v var)])
(make-PolyRow (list 'var) ty consts))]))
(define-syntax-rule (-poly (vars ...) ty)
(let ([vars (-v vars)] ...) (make-Poly (list 'vars ...) ty)))

(define-syntax-rule (-polydots (vars ... dotted) ty)
(let ([dotted (-v dotted)]
[vars (-v vars)] ...)
(make-PolyDots (list 'vars ... 'dotted) ty)))

(define-syntax-rule (-polyrow (var) consts ty)
(let ([var (-v var)]) (make-PolyRow (list 'var) ty consts)))

;; abbreviation for existential types
(define-syntax -some
(syntax-rules ()
[(_ (vars ...) ty)
(let ([vars (-v vars)] ...)
(make-Some (list 'vars ...) ty))]))
(define-syntax-rule (-some (vars ...) ty)
(let ([vars (-v vars)] ...) (make-Some (list 'vars ...) ty)))

;; abbreviation for existential type results
(define-syntax -some-res
Expand Down
26 changes: 14 additions & 12 deletions typed-racket-lib/typed-racket/types/generalize.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,10 +1,12 @@
#lang racket/base

(require "../utils/utils.rkt"
(require racket/match
"../rep/type-rep.rkt"
"abbrev.rkt" "subtype.rkt" "substitute.rkt"
"../utils/utils.rkt"
"abbrev.rkt"
"numeric-tower.rkt"
racket/match)
"substitute.rkt"
"subtype.rkt")

(provide generalize)

Expand Down Expand Up @@ -45,15 +47,15 @@
[(Pair: t1 (== -Null)) (-lst t1)]
[(MPair: t1 (== -Null)) (-mlst t1)]
[(or (Pair: t1 t2) (MPair: t1 t2))
(let ([t-new (loop t2)])
(define -lst-type
((match t*
[(Pair: _ _) -lst]
[(MPair: _ _) -mlst])
t1))
(if (type-equiv? -lst-type t-new)
-lst-type
(exit t)))]
(define t-new (loop t2))
(define -lst-type
((match t*
[(Pair: _ _) -lst]
[(MPair: _ _) -mlst])
t1))
(if (type-equiv? -lst-type t-new)
-lst-type
(exit t))]
[(ListDots: t bound) (-lst (substitute Univ bound t))]
[(? (lambda (t) (subtype t -Symbol))) -Symbol]
[(== -True) -Boolean]
Expand Down
17 changes: 9 additions & 8 deletions typed-racket-lib/typed-racket/types/match-expanders.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,16 +1,17 @@
#lang racket/base

(require "../utils/utils.rkt"
"../rep/type-rep.rkt"
"../rep/values-rep.rkt"
"../rep/rep-utils.rkt"
(require (for-syntax racket/base
syntax/parse)
racket/match
syntax/parse/define
racket/set
racket/unsafe/undefined
"resolve.rkt"
syntax/parse/define
"../rep/rep-utils.rkt"
"../rep/type-rep.rkt"
"../rep/values-rep.rkt"
"../utils/utils.rkt"
"base-abbrev.rkt"
(for-syntax racket/base syntax/parse))
"resolve.rkt")

(provide Listof: List: MListof: AnyPoly: AnyPoly-names:
HashTableTop:
Expand Down Expand Up @@ -75,7 +76,7 @@
(app (λ (t) (Listof? t #t)) (? Type? elem-pat)))])))


(define-simple-macro (make-Listof-pred listof-pred?:id pair-matcher:id)
(define-syntax-parse-rule (make-Listof-pred listof-pred?:id pair-matcher:id)
(define (listof-pred? t [simple? #f])
(match t
[(Mu-unsafe:
Expand Down
14 changes: 7 additions & 7 deletions typed-racket-lib/typed-racket/types/overlap.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,16 +1,16 @@
#lang racket/base

(require "../utils/utils.rkt"
"../utils/prefab.rkt"
"../rep/type-rep.rkt"
(require racket/match
(prefix-in c: (contract-req))
"../rep/rep-utils.rkt"
"../rep/type-mask.rkt"
(prefix-in c: (contract-req))
"../rep/type-rep.rkt"
"../utils/prefab.rkt"
"../utils/utils.rkt"
"abbrev.rkt"
"resolve.rkt"
"subtype.rkt"
"resolve.rkt"
"utils.rkt"
racket/match)
"utils.rkt")


(provide overlap?)
Expand Down
113 changes: 55 additions & 58 deletions typed-racket-lib/typed-racket/types/printer.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -132,7 +132,7 @@
(define name-ref->sexp
(match-lambda
[(? syntax? name-ref) (syntax-e name-ref)]
[(cons lvl arg) `(,lvl ,arg)]))
[(cons lvl arg) (list lvl arg)]))

;; prop->sexp : Prop -> S-expression
;; Print a Prop (see prop-rep.rkt) to the given port
Expand All @@ -149,20 +149,19 @@
;; instead of (<= x y) (<= y x) when we have both inequalities
(define-values (leqs others) (partition LeqProp? ps))
(define-values (eqs simple-leqs)
(for/fold ([eqs '()] [simple-leqs '()])
(for/fold ([eqs '()]
[simple-leqs '()])
([leq (in-list leqs)])
(match leq
[(LeqProp: lhs rhs)
(define flip (-leq rhs lhs))
(cond
[(not (member flip leqs))
(values eqs (cons leq simple-leqs))]
[(member flip eqs) (values eqs simple-leqs)]
[else (values (cons leq eqs) simple-leqs)])])))
(match-define (LeqProp: lhs rhs) leq)
(define flip (-leq rhs lhs))
(cond
[(not (member flip leqs)) (values eqs (cons leq simple-leqs))]
[(member flip eqs) (values eqs simple-leqs)]
[else (values (cons leq eqs) simple-leqs)])))
(let ([simple-leqs (map prop->sexp simple-leqs)]
[eqs (for/list ([leq (in-list eqs)])
(match leq
[(LeqProp: lhs rhs) `(= ,(object->sexp lhs) ,(object->sexp rhs))]))]
(match-define (LeqProp: lhs rhs) leq)
`(= ,(object->sexp lhs) ,(object->sexp rhs)))]
[others (map prop->sexp others)])
(match (append eqs simple-leqs others)
[(list sexp) sexp]
Expand Down Expand Up @@ -317,37 +316,36 @@
valid-names))
;; some types in the union may not be coverable by the candidates
;; (e.g. type variables, etc.)
(define-values (uncoverable coverable)
(values (apply set-subtract elems (map cdr candidates))
(set-intersect elems (apply set-union null (map cdr candidates)))))
(define uncoverable (apply set-subtract elems (map cdr candidates)))
(define coverable (set-intersect elems (apply set-union null (map cdr candidates))))
;; set cover, greedy algorithm, ~lg n approximation
(let loop ([to-cover coverable]
[candidates candidates]
[coverage '()])
(cond [(null? to-cover) ; done
(define coverage-names (map car coverage))
;; to allow :type to cue the user on unexpanded aliases
;; only union types can flow here, and any of those could be expanded
(set-box! (current-print-unexpanded)
(append coverage-names (unbox (current-print-unexpanded))))
;; reverse here to retain the old ordering from when srfi/1 was
;; used to process the list sets
(values coverage-names (reverse uncoverable))] ; we want the names
[else
;; pick the candidate that covers the most uncovered types
(define (covers-how-many? c)
(length (set-intersect (cdr c) to-cover)))
(define-values (next _)
(for/fold ([next (car candidates)]
[max-cover (covers-how-many? (car candidates))])
([c (in-list candidates)])
(let ([how-many? (covers-how-many? c)])
(if (> how-many? max-cover)
(values c how-many?)
(values next max-cover)))))
(loop (set-subtract to-cover (cdr next))
(remove next candidates)
(cons next coverage))])))
(cond
[(null? to-cover) ; done
(define coverage-names (map car coverage))
;; to allow :type to cue the user on unexpanded aliases
;; only union types can flow here, and any of those could be expanded
(set-box! (current-print-unexpanded)
(append coverage-names (unbox (current-print-unexpanded))))
;; reverse here to retain the old ordering from when srfi/1 was
;; used to process the list sets
(values coverage-names (reverse uncoverable))] ; we want the names
[else
;; pick the candidate that covers the most uncovered types
(define (covers-how-many? c)
(length (set-intersect (cdr c) to-cover)))
(define next
(for/fold ([next (car candidates)]
[max-cover (covers-how-many? (car candidates))]
#:result next)
([c (in-list candidates)])
(let ([how-many? (covers-how-many? c)])
(if (> how-many? max-cover)
(values c how-many?)
(values next max-cover)))))
(loop (set-subtract to-cover (cdr next)) (remove next candidates) (cons next coverage))])))

;; arr->sexp : arr -> s-expression
;; Convert an arr (see type-rep.rkt) to its printable form
Expand All @@ -365,11 +363,10 @@
;; as long as the resulting s-expressions are `display`ed
;; this is fine, though it may not pretty-print well.
(for/list ([kw (in-list kws)])
(match kw
[(Keyword: k t req?)
(if req?
(format "~a ~a" k (type->sexp t))
(format "[~a ~a]" k (type->sexp t)))]))
(match-define (Keyword: k t req?) kw)
(if req?
(format "~a ~a" k (type->sexp t))
(format "[~a ~a]" k (type->sexp t))))
(match rst
[(Rest: (list rst-t)) `(,(type->sexp rst-t) *)]
[(Rest: rst-ts) `(#:rest-star ,(map type->sexp rst-ts))]
Expand Down Expand Up @@ -461,8 +458,9 @@
(define-values (pre mid) (split-at lst to-drop))
(define-values (sub post) (split-at mid n))
(list pre sub post)))
(apply append (for/list ([i (range (length lst) 0 -1)])
(sublist-n i lst))))
(for*/list ([i (range (length lst) 0 -1)]
[v (in-list (sublist-n i lst))])
v))
(let loop ([left-to-cover arrs])
;; try to match the largest sublists possible that correspond to
;; ->* types and then the remainder are formatted normally
Expand All @@ -478,16 +476,15 @@
;; case-lambda->sexp : Type -> S-expression
;; Convert a case-> type to an s-expression
(define (case-lambda->sexp type)
(match type
Copy link
Member

@samth samth Nov 8, 2024

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

These two matches could be combined which would be better.

Copy link
Contributor

@jackfirth jackfirth Nov 8, 2024

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm not sure I agree, particularly since the third branch of the second match wants to refer to the arrows variable anyway. This is how I'd write it:

(match-define (Fun: arrows) type)
(match arrows
  [(list) '(case->)]
  [(list a) (arr->sexp a)]
  [(list a b ...)
   (define cover (cover-case-lambda arrows))
   (if (> (length cover) 1)
       `(case-> ,@cover)
       (car cover))])

Copy link
Member

@samth samth Nov 8, 2024

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I guess I think I prefer:

(match type
  [(Fun: (list)) '(case->)]
  [(Fun: (list a)) (arr->sexp a)]
  [(Fun: arrows)
   (define cover (cover-case-lambda arrows))
   (if (> (length cover) 1)
       `(case-> ,@cover)
       (car cover))])

but that might be hard to generate automatically

Copy link
Contributor

@jackfirth jackfirth Nov 8, 2024

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

That looks quite reasonable. However, this all seems way too subjective for Resyntax to tackle.

[(Fun: arrows)
(match arrows
[(list) '(case->)]
[(list a) (arr->sexp a)]
[(and arrs (list a b ...))
(define cover (cover-case-lambda arrs))
(if (> (length cover) 1)
`(case-> ,@cover)
(car cover))])]))
(match-define (Fun: arrows) type)
(match arrows
[(list) '(case->)]
[(list a) (arr->sexp a)]
[(and arrs (list a b ...))
(define cover (cover-case-lambda arrs))
(if (> (length cover) 1)
`(case-> ,@cover)
(car cover))]))

;; class->sexp : Class [#:object? Boolean] -> S-expression
;; Convert a class or object type to an s-expression
Expand All @@ -512,11 +509,11 @@
(cons 'field
(for/list ([name+type (in-list fields)])
(match-define (list name type) name+type)
`(,name ,(type->sexp type)))))))
(list name (type->sexp type)))))))
(define methods*
(for/list ([name+type (in-list methods)])
(match-define (list name type) name+type)
`(,name ,(type->sexp type))))
(list name (type->sexp type))))
(define augments*
(cond [(or object? (null? augments)) '()]
[else (list (cons 'augment augments))]))
Expand Down
Loading
Loading