You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
602 lines
21 KiB
Scheme
602 lines
21 KiB
Scheme
27 years ago
|
; hyper.ss - interface to GUI
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
||
|
|
;
|
||
|
|
; This program is free software; you can redistribute it and/or
|
||
|
|
; modify it under the terms of the GNU General Public License
|
||
|
|
; version 2 as published by the Free Software Foundation.
|
||
|
|
;
|
||
|
|
; This program is distributed in the hope that it will be useful,
|
||
|
|
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
; GNU General Public License for more details.
|
||
|
|
;
|
||
|
|
; You should have received a copy of the GNU General Public License
|
||
|
|
; along with this program; if not, write to the Free Software
|
||
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
;;----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (st:analyze-and-make-annotations filename)
|
||
|
|
(analysis-set-arrow-filter! #f)
|
||
|
|
(record-analyzed-file
|
||
|
|
filename
|
||
|
|
(lambda () (open-code-file filename))
|
||
|
|
(lambda () (analyze-program filename))))
|
||
|
|
|
||
|
|
(define (calc-annotations defs)
|
||
|
|
(match-let*
|
||
|
|
([type-annotations (calc-type-annotations defs)]
|
||
|
|
[(check-annotations uncheck-annotations) (calc-checks defs)]
|
||
|
|
[all-annotations
|
||
|
|
(vector type-annotations check-annotations uncheck-annotations)])
|
||
|
|
;;(pretty-debug `(links ,all-annotations))
|
||
|
|
all-annotations))
|
||
|
|
|
||
|
|
;;----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define arrow-filter #f) ; if not #f, then a list of templates
|
||
|
|
; only show pred with matching AV
|
||
|
|
|
||
|
|
(define (analysis-set-arrow-filter! C)
|
||
|
|
(set! arrow-filter
|
||
|
|
(if C
|
||
|
|
(map lookup-template (list C))
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
(define (analysis-filter-on?)
|
||
|
|
(and arrow-filter (symbol->string (template-type (car arrow-filter)))))
|
||
|
|
|
||
|
|
(define (analysis-get-filters)
|
||
|
|
(cons
|
||
|
|
(cons "No filter" #f)
|
||
|
|
(map
|
||
|
|
(lambda (C) (cons (symbol->string C) C))
|
||
|
|
(append
|
||
|
|
`( nil num sym str void undefined true false
|
||
|
|
box cons vec eof iport oport
|
||
|
|
promise unit thread hash-table regexp parameterization semaphore)
|
||
|
|
(filter
|
||
|
|
(lambda (x) x)
|
||
|
|
(hash-table-map
|
||
|
|
constructor-env
|
||
|
|
(lambda (c template)
|
||
|
|
(and
|
||
|
|
(memq template-structure (template-super-templates template))
|
||
|
|
c))))))))
|
||
|
|
|
||
|
|
;; ------------------------------
|
||
|
|
|
||
|
|
(define (objs-contain-filter? objs)
|
||
|
|
(or
|
||
|
|
(and
|
||
|
|
(eq? arrow-filter #f)
|
||
|
|
(not (null? objs)))
|
||
|
|
(ormap
|
||
|
|
(lambda (AV)
|
||
|
|
(memq (AV-template AV) arrow-filter))
|
||
|
|
objs)))
|
||
|
|
|
||
|
|
(define (tvar-contain-filter-mvalues? get-Tvar-objs tvar)
|
||
|
|
(or
|
||
|
|
(objs-contain-filter? (get-Tvar-objs tvar))
|
||
|
|
(ormap
|
||
|
|
(match-lambda
|
||
|
|
[($ AV _ (? (eqc? template-mvalues)) _ #(tvar-mvlist))
|
||
|
|
;;(pretty-debug `(tvar-mvlist ,(Tvar-name tvar-mvlist)))
|
||
|
|
(ormap
|
||
|
|
(match-lambda
|
||
|
|
[($ AV _ (? (eqc? template-cons)) _ #(tvar-car-mvlist _))
|
||
|
|
(objs-contain-filter? (get-Tvar-objs tvar-car-mvlist))]
|
||
|
|
[_ #f])
|
||
|
|
(get-Tvar-objs tvar-mvlist))]
|
||
|
|
[_ #f])
|
||
|
|
(get-Tvar-objs tvar))))
|
||
|
|
|
||
|
|
(define (FlowType-contains-filter? ftype)
|
||
|
|
;(pretty-debug `(FlowType-contains-filter? ,(FlowType-name ftype)))
|
||
|
|
(or
|
||
|
|
(not arrow-filter)
|
||
|
|
(match (FlowType->Atype ftype)
|
||
|
|
[(or (? atconst?) (? atprim?) (? Tvar?))
|
||
|
|
(tvar-contain-filter-mvalues? Tvar-objs (FlowType->Tvar ftype))]
|
||
|
|
[($ atvalues (val1 . _))
|
||
|
|
(FlowType-contains-filter? val1)]
|
||
|
|
;; other atypes are atschema atthunk, atstruct, atunit, atlunit
|
||
|
|
;; all are too expensive to convert.
|
||
|
|
[x
|
||
|
|
(pretty-debug `(FlowType-contains-filter? unhandled-atype x))
|
||
|
|
#f])))
|
||
|
|
|
||
|
|
(define (FlowType-orig-objs-contains-filter? ftype)
|
||
|
|
;;(pretty-debug `(FlowType-orig-contains-filter? ,(FlowType-name ftype)))
|
||
|
|
(match (FlowType->Atype ftype)
|
||
|
|
[(or (? Tvar?))
|
||
|
|
(tvar-contain-filter-mvalues? Tvar-orig-objs (FlowType->Tvar ftype))]
|
||
|
|
[($ atvalues (val1 . _))
|
||
|
|
(FlowType-orig-objs-contains-filter? val1)]
|
||
|
|
;; other atypes are atschema atthunk, atstruct, atunit, atlunit
|
||
|
|
;; all are too expensive to convert.
|
||
|
|
[x
|
||
|
|
(pretty-debug `(FlowType-orig-objs-contains-filter? unhandled-atype x))
|
||
|
|
#f]))
|
||
|
|
|
||
|
|
;;----------------------------------------------------------------------
|
||
|
|
;; Abstracts over parents and children
|
||
|
|
|
||
|
|
(define analysis-walk1
|
||
|
|
(lambda (start in-get-edges file-visable?)
|
||
|
|
(assert (FlowType? start))
|
||
|
|
(pretty-debug `(analysis-walk1 ,(FlowType-name start)))
|
||
|
|
(if (string? (FlowType-type-annotation start))
|
||
|
|
;; start from .za file, show no edges
|
||
|
|
'()
|
||
|
|
(letrec*
|
||
|
|
( [traversed '()] ; list of FlowType's
|
||
|
|
[preds '()] ; visable FlowType's
|
||
|
|
[get-edges
|
||
|
|
(lambda (ftype)
|
||
|
|
(let ([r (in-get-edges ftype)])
|
||
|
|
(pretty-debug `(get-edges ,(map FlowType-name (cons ftype r))))
|
||
|
|
r))]
|
||
|
|
[traverse
|
||
|
|
(lambda (ftype)
|
||
|
|
(pretty-debug `(traverse ,(FlowType-name ftype)))
|
||
|
|
(when
|
||
|
|
(and
|
||
|
|
(FlowType-contains-filter? ftype)
|
||
|
|
(not (memq ftype traversed)))
|
||
|
|
(set! traversed (cons ftype traversed))
|
||
|
|
(let*
|
||
|
|
( [ftype-w/-ta (get-ftype-w/-ta ftype)]
|
||
|
|
[ta (and ftype-w/-ta
|
||
|
|
(FlowType-type-annotation ftype-w/-ta))])
|
||
|
|
(pretty-debug
|
||
|
|
`(traverse-ftype-w/-ta
|
||
|
|
,(and ftype-w/-ta (FlowType-name ftype-w/-ta))))
|
||
|
|
|
||
|
|
(cond
|
||
|
|
[(not ta)
|
||
|
|
;; invisable
|
||
|
|
;; Go back to parents
|
||
|
|
(for-each traverse (get-edges ftype))]
|
||
|
|
|
||
|
|
[(string? ta)
|
||
|
|
(if (file-visable? ta)
|
||
|
|
|
||
|
|
;; ftype from .za file, source file is loaded
|
||
|
|
;; can follow this edge unless dest is from same file
|
||
|
|
(for-each
|
||
|
|
(lambda (ftype2)
|
||
|
|
(let ([ta2 (FlowType-type-annotation ftype2)])
|
||
|
|
(unless (and (string? ta2) (string=? ta ta2))
|
||
|
|
(traverse ftype2))))
|
||
|
|
(get-edges ftype))
|
||
|
|
|
||
|
|
;; .za file, source file not loaded
|
||
|
|
(set! preds (cons ftype-w/-ta preds)))]
|
||
|
|
|
||
|
|
[(and
|
||
|
|
(not (string? ta))
|
||
|
|
(not (eq? ftype-w/-ta start)))
|
||
|
|
|
||
|
|
;; visable
|
||
|
|
;; add to preds unless src and dest are single value
|
||
|
|
(set! preds (cons ftype-w/-ta preds))]
|
||
|
|
|
||
|
|
[else
|
||
|
|
;; Invisable
|
||
|
|
;; Go back to parents
|
||
|
|
(for-each traverse (get-edges ftype))]))))])
|
||
|
|
|
||
|
|
(for-each traverse (get-edges start))
|
||
|
|
|
||
|
|
(pretty-debug `(traversed ,(map FlowType-name traversed)))
|
||
|
|
(pretty-debug
|
||
|
|
`(preds ,(map
|
||
|
|
(lambda (i) (and (FlowType? i) (FlowType-name i)))
|
||
|
|
preds)))
|
||
|
|
|
||
|
|
(remq start preds)))))
|
||
|
|
|
||
|
|
(define (get-ftype-w/-ta ftype)
|
||
|
|
(if (FlowType-type-annotation ftype)
|
||
|
|
ftype
|
||
|
|
(and (FlowType-values-ftype ftype)
|
||
|
|
(get-ftype-w/-ta (FlowType-values-ftype ftype)))))
|
||
|
|
|
||
|
|
(define (single-value-ftype ftype)
|
||
|
|
(let ([r
|
||
|
|
(match (FlowType->Atype ftype)
|
||
|
|
[(? Tvar? tvar)
|
||
|
|
(ormap
|
||
|
|
(lambda (AV) (not (eq? (AV-template AV) template-mvalues)))
|
||
|
|
(get-Tvar-objs tvar))]
|
||
|
|
[($ atvalues) #f]
|
||
|
|
[_ #t])])
|
||
|
|
(pretty-debug `(single-value-ftype ,(FlowType-name ftype) ,r))
|
||
|
|
r))
|
||
|
|
|
||
|
|
;;----------------------------------------------------------------------
|
||
|
|
;; Returns the preds in the Tvar graph of a given ftype
|
||
|
|
;; format is a list of Tvars of predecessors that are visable
|
||
|
|
|
||
|
|
(define analysis-parents
|
||
|
|
(lambda (ftype file-visable?)
|
||
|
|
(pretty-debug `(analysis-parents ,(FlowType-name ftype) ,(print-struct)))
|
||
|
|
(let ([r (analysis-walk1 ftype get-arrowfrom file-visable?)])
|
||
|
|
(pretty-debug `(analysis-parents-returns ,(map FlowType-name r)))
|
||
|
|
r)))
|
||
|
|
|
||
|
|
(define (get-arrowfrom to)
|
||
|
|
(append
|
||
|
|
(if (Tvar? to)
|
||
|
|
(append
|
||
|
|
(get-mvalue-components to)
|
||
|
|
(Tvar-edgefrom to))
|
||
|
|
'())
|
||
|
|
(match (FlowType->Atype to)
|
||
|
|
[($ atvalues ftypes)
|
||
|
|
ftypes]
|
||
|
|
[_ '()])
|
||
|
|
(FlowType-arrowfrom to)))
|
||
|
|
|
||
|
|
(define (get-mvalue-components tvar)
|
||
|
|
'(pretty-debug `(get-mvalue-components ,(Tvar-name tvar)))
|
||
|
|
(filter-map
|
||
|
|
(lambda (AV)
|
||
|
|
(if (eq? (AV-template AV) template-mvalues)
|
||
|
|
;; get-nth
|
||
|
|
(let ( [p (mk-Tvar 'p)]
|
||
|
|
[l (mk-Tvar 'l)])
|
||
|
|
(new-edge! (vector-ref (AV-fields+ AV) 0) p)
|
||
|
|
(new-con! p (make-con-cdr p))
|
||
|
|
(new-con! p (make-con-car l))
|
||
|
|
'(pretty-debug
|
||
|
|
`(get-mvalue-components
|
||
|
|
,(Tvar-name tvar) ,(Tvar-name p) ,(Tvar-name l)))
|
||
|
|
l)
|
||
|
|
#f))
|
||
|
|
(get-Tvar-objs tvar)))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define analysis-children
|
||
|
|
(lambda (ftype file-visable?)
|
||
|
|
(analysis-walk1
|
||
|
|
ftype
|
||
|
|
FlowType-alledgeto
|
||
|
|
file-visable?)))
|
||
|
|
|
||
|
|
(define FlowType-alledgeto
|
||
|
|
(lambda (ftype)
|
||
|
|
(append
|
||
|
|
;; Direct successors
|
||
|
|
(FlowType-arrowto ftype)
|
||
|
|
(if (FlowType-values-ftype ftype)
|
||
|
|
(list (FlowType-values-ftype ftype))
|
||
|
|
'())
|
||
|
|
;; For filter successors, make sure some same values
|
||
|
|
(if (Tvar? ftype)
|
||
|
|
(append
|
||
|
|
(Tvar-edgeto ftype)
|
||
|
|
(filter-map
|
||
|
|
(match-lambda
|
||
|
|
[($ con-filter _ _ tvar) tvar]
|
||
|
|
[_ #f])
|
||
|
|
(Tvar-constraints ftype)))
|
||
|
|
'()))))
|
||
|
|
|
||
|
|
;;----------------------------------------------------------------------
|
||
|
|
;; Returns all ancestor/descendant arrows of a given ftype
|
||
|
|
;; as (listof (list from to))
|
||
|
|
|
||
|
|
(define analysis-walkn
|
||
|
|
(lambda (ftype get-edges file-visable?)
|
||
|
|
(assert (FlowType? ftype))
|
||
|
|
(pretty-debug `(analysis-walkn ,(FlowType-name ftype)))
|
||
|
|
;;(error)
|
||
|
|
(let ( [done '()] ; list of FlowType's
|
||
|
|
[arrows '()]) ; visable arrows
|
||
|
|
(recur traverse ([ftype ftype])
|
||
|
|
(unless (memq ftype done)
|
||
|
|
(set! done (cons ftype done))
|
||
|
|
(let ([parents (analysis-walk1 ftype get-edges file-visable?)])
|
||
|
|
(for-each
|
||
|
|
(lambda (p)
|
||
|
|
(set! arrows (cons (list p ftype) arrows))
|
||
|
|
(traverse p))
|
||
|
|
parents))))
|
||
|
|
|
||
|
|
arrows)))
|
||
|
|
|
||
|
|
;;----------------------------------------------------------------------
|
||
|
|
;; Returns all ancestor arrows of a given ftype
|
||
|
|
;; as (listof (list from to))
|
||
|
|
|
||
|
|
(define analysis-ancestors
|
||
|
|
(lambda (ftype file-visable?)
|
||
|
|
(analysis-walkn ftype get-arrowfrom file-visable?)))
|
||
|
|
|
||
|
|
(define analysis-descendants
|
||
|
|
(lambda (ftype file-visable?)
|
||
|
|
(map reverse
|
||
|
|
(analysis-walkn ftype FlowType-alledgeto file-visable?))))
|
||
|
|
|
||
|
|
;;----------------------------------------------------------------------
|
||
|
|
;; Calcs the shortest path to a source FlowType with
|
||
|
|
;; orig-objs matching filter via breadth-first search
|
||
|
|
;; Returns a list of FlowTypes
|
||
|
|
;; or nil if no path to visable source
|
||
|
|
;; or #f if ftype does not contain filter
|
||
|
|
|
||
|
|
(define analysis-shortest-path
|
||
|
|
(lambda (ftype file-visable?)
|
||
|
|
(assert (FlowType? ftype))
|
||
|
|
(if (FlowType-contains-filter? ftype)
|
||
|
|
(let ([visited (list ftype)])
|
||
|
|
(letrec
|
||
|
|
([traverse
|
||
|
|
(lambda (list-paths)
|
||
|
|
(pretty-debug
|
||
|
|
`(list-paths
|
||
|
|
,(map (lambda (p) (map FlowType-name p)) list-paths)
|
||
|
|
,(map FlowType-name visited)))
|
||
|
|
(match list-paths
|
||
|
|
[()
|
||
|
|
;; No paths -> return the empty path
|
||
|
|
'()]
|
||
|
|
[((and path (ftype . rest-path)) . rest-paths)
|
||
|
|
(pretty-debug
|
||
|
|
`(path ,(map FlowType-name path)
|
||
|
|
rest-paths
|
||
|
|
,(map (lambda (p) (map FlowType-name p)) rest-paths)))
|
||
|
|
(let* ( [parents1 (analysis-parents ftype file-visable?)]
|
||
|
|
[parents2
|
||
|
|
(filter
|
||
|
|
(lambda (p)
|
||
|
|
(if (memq p visited)
|
||
|
|
#f
|
||
|
|
(begin
|
||
|
|
(set! visited (cons p visited))
|
||
|
|
#t)))
|
||
|
|
parents1)])
|
||
|
|
(set! visited (cons ftype visited))
|
||
|
|
(if (and (null? parents2)
|
||
|
|
(or (null? parents1)
|
||
|
|
(null? rest-paths)))
|
||
|
|
;; either this path has terminated,
|
||
|
|
;; or went to cycle and is only one left.
|
||
|
|
;; either way, return it
|
||
|
|
(reverse path)
|
||
|
|
(traverse
|
||
|
|
(append rest-paths
|
||
|
|
(filter-map
|
||
|
|
(lambda (parent) (cons parent path))
|
||
|
|
parents2)))))]))])
|
||
|
|
|
||
|
|
(let ([path (traverse
|
||
|
|
(map list (analysis-parents ftype file-visable?)))])
|
||
|
|
|
||
|
|
(pretty-debug `(traverse-path ,(map FlowType-name path)))
|
||
|
|
|
||
|
|
path)))
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
'(define analysis-shortest-path
|
||
|
|
(lambda (ftype file-visable?)
|
||
|
|
(assert (FlowType? ftype))
|
||
|
|
(if (FlowType-contains-filter? ftype)
|
||
|
|
(let ([visited '()])
|
||
|
|
(letrec
|
||
|
|
([traverse
|
||
|
|
(lambda (list-paths)
|
||
|
|
(pretty-debug
|
||
|
|
`(list-paths
|
||
|
|
,(map (lambda (p) (map FlowType-name p)) list-paths)
|
||
|
|
,(map FlowType-name visited)))
|
||
|
|
(match list-paths
|
||
|
|
[()
|
||
|
|
;; No paths -> return the empty path
|
||
|
|
'()]
|
||
|
|
[((and path (ftype . rest-path)) . rest-paths)
|
||
|
|
(pretty-debug
|
||
|
|
`(path ,(map FlowType-name path)
|
||
|
|
rest-paths
|
||
|
|
,(map (lambda (p) (map FlowType-name p)) rest-paths)))
|
||
|
|
(if (memq ftype visited)
|
||
|
|
;; going around a loop
|
||
|
|
(traverse rest-paths)
|
||
|
|
(let* ( [parents (analysis-parents ftype file-visable?)])
|
||
|
|
(set! visited (cons ftype visited))
|
||
|
|
(if (and (null? parents) (null? rest-paths))
|
||
|
|
;; this path has terminated, and is the only one left,
|
||
|
|
;; and hence the longest, so return it
|
||
|
|
(reverse path)
|
||
|
|
(traverse
|
||
|
|
(append rest-paths
|
||
|
|
(filter-map
|
||
|
|
(lambda (parent) (cons parent path))
|
||
|
|
parents))))))]))])
|
||
|
|
|
||
|
|
(let ([path (traverse
|
||
|
|
(map list (analysis-parents ftype file-visable?)))])
|
||
|
|
|
||
|
|
(pretty-debug `(traverse-path ,(map FlowType-name path)))
|
||
|
|
|
||
|
|
path)))
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
'(define analysis-shortest-path
|
||
|
|
(lambda (ftype file-visable?)
|
||
|
|
(assert (FlowType? ftype))
|
||
|
|
(let ([visited '()])
|
||
|
|
(letrec
|
||
|
|
([traverse
|
||
|
|
(lambda (list-paths)
|
||
|
|
(pretty-debug
|
||
|
|
`(list-paths
|
||
|
|
,(map (lambda (p) (map FlowType-name p)) list-paths)
|
||
|
|
,(map FlowType-name visited)))
|
||
|
|
(match list-paths
|
||
|
|
[()
|
||
|
|
;; No paths -> return the empty path
|
||
|
|
'()]
|
||
|
|
[((and path (ftype . rest-path)) . rest-paths)
|
||
|
|
(if (memq ftype visited)
|
||
|
|
|
||
|
|
;; Visited on a shorter path
|
||
|
|
(traverse rest-paths)
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(pretty-print
|
||
|
|
`(path ,(map FlowType-name path)
|
||
|
|
rest-paths
|
||
|
|
,(map (lambda (p) (map FlowType-name p)) rest-paths)))
|
||
|
|
(set! visited (cons ftype visited))
|
||
|
|
(cond
|
||
|
|
[(FlowType-orig-objs-contains-filter? ftype)
|
||
|
|
;; Has orig-objs that match the filter
|
||
|
|
;; => return this path
|
||
|
|
(reverse path)]
|
||
|
|
[(FlowType-contains-filter? ftype)
|
||
|
|
;; Has propogated objs that match the filter
|
||
|
|
;; => go back to parent
|
||
|
|
(let* ([new-paths
|
||
|
|
(map
|
||
|
|
(lambda (parent) (cons parent path))
|
||
|
|
(get-arrowfrom ftype))])
|
||
|
|
(pretty-print
|
||
|
|
`(rest-paths ,(map (lambda (p) (map FlowType-name p)) rest-paths)
|
||
|
|
new-paths
|
||
|
|
,(map (lambda (p) (map FlowType-name p)) new-paths)))
|
||
|
|
(traverse (append rest-paths new-paths)))]
|
||
|
|
[else
|
||
|
|
;; This FlowType no good
|
||
|
|
(traverse rest-paths)])))]))])
|
||
|
|
(let ([path (traverse (list (list ftype)))])
|
||
|
|
|
||
|
|
(pretty-print `(traverse-path ,(map FlowType-name path)))
|
||
|
|
;; Drop first FlowType - it is us
|
||
|
|
;; Remove invisable FlowType's
|
||
|
|
;; NO LONGER Add '() as last tag if last FlowType invisable
|
||
|
|
(assert (or (null? path) (eq? (car path) ftype)))
|
||
|
|
(if (null? path)
|
||
|
|
'()
|
||
|
|
(recur loop ([path (cdr path)])
|
||
|
|
(match path
|
||
|
|
[(ftype . rest)
|
||
|
|
(cond
|
||
|
|
[(FlowType-type-annotation ftype) (cons ftype (loop rest))]
|
||
|
|
[(null? rest) '()]
|
||
|
|
[else (loop rest)])]
|
||
|
|
[()
|
||
|
|
;; No path
|
||
|
|
'()]))))))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
;; Returns a string representation of the the type
|
||
|
|
|
||
|
|
(define (FlowType->SDL-text ftype)
|
||
|
|
(let ([type-port (open-output-string)])
|
||
|
|
(dynamic-let
|
||
|
|
([pretty-print-columns (st:pretty-type-width)])
|
||
|
|
(pretty-print (FlowType->SDL ftype) type-port))
|
||
|
|
(begin0
|
||
|
|
(get-output-string type-port)
|
||
|
|
(close-output-port type-port))))
|
||
|
|
|
||
|
|
(define analysis-callback
|
||
|
|
(lambda (ftype)
|
||
|
|
(assert (FlowType? ftype) 'analysis-callback ftype)
|
||
|
|
(pretty-debug `(analysis-callback ,(FlowType->pretty ftype)))
|
||
|
|
(FlowType->SDL-text ftype)))
|
||
|
|
|
||
|
|
;;----------------------------------------------------------------------
|
||
|
|
|
||
|
|
'(define test-hyper
|
||
|
|
(lambda (files)
|
||
|
|
(initialize-analysis!)
|
||
|
|
(match-let*
|
||
|
|
([(defs in out)
|
||
|
|
(sba-analyze-file (files->file-thunk* files))])
|
||
|
|
(set! global-in-env in-env)
|
||
|
|
(set! global-out-env out-env)
|
||
|
|
(report-unbound-vars)
|
||
|
|
(hyper defs)
|
||
|
|
(printf "Testing parents~n")
|
||
|
|
(pretty-print (mapLR analysis-parents list-ftype))
|
||
|
|
(printf "Testing analysis-shortest-path~n")
|
||
|
|
(pretty-print (mapLR analysis-shortest-path list-ftype))
|
||
|
|
(printf "Testing children~n")
|
||
|
|
(pretty-print (mapLR analysis-children list-ftype list-ftype))
|
||
|
|
(void))))
|
||
|
|
|
||
|
|
;; (trace analysis-parents analysis-shortest-path analysis-children)
|
||
|
|
|
||
|
|
;;----------------------------------------------------------------------
|
||
|
|
;; zodiac-based source-correlating pretty-printer
|
||
|
|
|
||
|
|
'(define (correlate-pretty-print sexp)
|
||
|
|
(let* ([p (open-output-string)]
|
||
|
|
[_ (pretty-print sexp p)]
|
||
|
|
[s (get-output-string p)]
|
||
|
|
[_ (close-output-port p)]
|
||
|
|
[p (open-input-string p)]
|
||
|
|
[r (zodiac:read p)]
|
||
|
|
[zexp (r)])
|
||
|
|
(values s
|
||
|
|
(recur loop ([sexp sexp][zexp zexp])
|
||
|
|
(match (list sexp zexp)
|
||
|
|
[((? list? sl) ($ zodiac:list _ s f (? list? zl)))
|
||
|
|
(list
|
||
|
|
(zodiac:location-offset s)
|
||
|
|
(zodiac:location-offset f)
|
||
|
|
(map loop sl zl))]
|
||
|
|
[(sexp ($ zodiac:zodiac _ s f))
|
||
|
|
(list
|
||
|
|
(zodiac:location-offset s)
|
||
|
|
(zodiac:location-offset f)
|
||
|
|
sexp)])))))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
'(define analysis-get-pred-filter-list
|
||
|
|
(lambda ()
|
||
|
|
(cons (cons "All sources" #f)
|
||
|
|
(reverse
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[(con . constructor) (cons (symbol->string con) (list con))])
|
||
|
|
(append constructor-env default-constructor-env))))))
|
||
|
|
|
||
|
|
(define analysis-get-param
|
||
|
|
(lambda (param)
|
||
|
|
((eval param))))
|
||
|
|
|
||
|
|
(define analysis-set-param!
|
||
|
|
(lambda (param val)
|
||
|
|
((eval param) val)))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
;; ----------
|
||
|
|
|
||
|
|
'(define (contains-some-same-vals? ftype value-from-ftypes)
|
||
|
|
;; Returns #t if ftype contains at least some values from
|
||
|
|
;; each of value-from-ftypes
|
||
|
|
(andmap
|
||
|
|
(lambda (value-from-ftype)
|
||
|
|
(match (list
|
||
|
|
(FlowType->Atype ftype)
|
||
|
|
(FlowType->Atype value-from-ftype))
|
||
|
|
[((? fo-Atype? x) (? fo-Atype? y)) (eq? x y)]
|
||
|
|
[((? Tvar? x) (? Tvar? y))
|
||
|
|
(ormap
|
||
|
|
(lambda (AV) (memq AV (get-Tvar-objs y)))
|
||
|
|
(get-Tvar-objs x))]
|
||
|
|
[_ #t]))
|
||
|
|
value-from-ftypes))
|