macro stepper: changed hiding policy impl
svn: r12332
This commit is contained in:
Ryan Culpepper
parent
cbecece203
commit
f78ce2c9f3
|
|
@ -3,13 +3,358 @@
|
|||
(require (for-syntax scheme/base)
|
||||
scheme/match
|
||||
syntax/boundmap
|
||||
"reductions-config.ss")
|
||||
(provide make-policy
|
||||
standard-policy
|
||||
"reductions-config.ss"
|
||||
"../util/mpi.ss")
|
||||
(provide policy->predicate)
|
||||
|
||||
;; A Policy is one of
|
||||
;; 'disable
|
||||
;; 'standard
|
||||
;; (list 'custom boolean boolean boolean boolean (listof Entry))
|
||||
|
||||
;; An Entry is one of
|
||||
;; (list 'show-if Condition)
|
||||
;; (list 'hide-if Condition)
|
||||
|
||||
;; A Condition is one of:
|
||||
;; (list 'free=? identifier)
|
||||
;; (list 'lexical)
|
||||
;; (list 'unbound)
|
||||
;; (list 'binding IdentifierBinding)
|
||||
;; (list 'symbol=? symbol)
|
||||
;; (list 'symbol-like regexp)
|
||||
;; (list 'from-kernel-module)
|
||||
;; (list 'from-def-module ModulePath)
|
||||
;; (list 'from-nom-module ModulePath)
|
||||
;; (list 'from-collection (listof String))
|
||||
;; (list 'from-planet-collection String/#f String/#f (listof String))
|
||||
;; (list 'phase>=? nat)
|
||||
;; (cons 'and Condition)
|
||||
;; (cons 'or Condition)
|
||||
|
||||
;; policy->predicate
|
||||
(define (policy->predicate policy)
|
||||
(define fun (policy->function policy))
|
||||
(lambda (id)
|
||||
(case (fun id)
|
||||
[(show) #t]
|
||||
[(hide) #f]
|
||||
[else (error 'policy->predicate "incomplete policy (returned ~s): ~s"
|
||||
(fun id)
|
||||
policy)])))
|
||||
|
||||
;; policy->function : Policy -> (id -> choice)
|
||||
(define (policy->function policy)
|
||||
(match policy
|
||||
['disable
|
||||
(lambda (id) 'show)]
|
||||
['standard
|
||||
(policy->function '(custom #t #t #t #t ()))]
|
||||
[(list 'custom hide-scheme? hide-libs? hide-contracts? hide-phase1? entries)
|
||||
(entries->function entries
|
||||
(policy-base->function hide-scheme?
|
||||
hide-libs?
|
||||
hide-contracts?
|
||||
hide-phase1?))]))
|
||||
|
||||
;; policy-base->function : boolean boolean boolean boolean -> (id -> choice)
|
||||
(define (policy-base->function hide-scheme? hide-libs? hide-contracts? hide-phase1?)
|
||||
(entries->function
|
||||
`[(hide-if
|
||||
(or ,@(filter values
|
||||
(list (and hide-scheme?
|
||||
'(or (from-kernel-module)
|
||||
(from-collection ("scheme"))))
|
||||
(and hide-libs?
|
||||
'(or (from-collection ())
|
||||
#;(from-planet-collection #f #f ())))
|
||||
(and hide-contracts?
|
||||
'(symbol-like #rx"^provide/contract-id-"))
|
||||
(and hide-phase1?
|
||||
'(phase>=? 1))))))]
|
||||
(lambda (id) 'show)))
|
||||
|
||||
;; entries->function : (listof Entry) (id -> choice) -> (id -> choice)
|
||||
(define (entries->function entries base-fun)
|
||||
(if (pair? entries)
|
||||
(let ([first-fun (entry->function (car entries))]
|
||||
[rest-fun (entries->function (cdr entries) base-fun)])
|
||||
(lambda (id)
|
||||
(or (first-fun id)
|
||||
(rest-fun id))))
|
||||
base-fun))
|
||||
|
||||
;; entry->function : Entry -> (id -> choice)
|
||||
(define (entry->function entry)
|
||||
(match entry
|
||||
[(list 'show-if condition)
|
||||
(let ([pred (condition->predicate condition)])
|
||||
(lambda (id)
|
||||
(if (pred id) 'show #f)))]
|
||||
[(list 'hide-if condition)
|
||||
(let ([pred (condition->predicate condition)])
|
||||
(lambda (id)
|
||||
(if (pred id) 'hide #f)))]
|
||||
[(list 'splice entries)
|
||||
(entries->function entries)]))
|
||||
|
||||
;; condition->predicate : condition -> (id -> boolean)
|
||||
(define (condition->predicate condition)
|
||||
(match condition
|
||||
[(list 'free=? the-id)
|
||||
(lambda (id)
|
||||
(free-identifier=? id the-id (phase)))]
|
||||
[(list 'lexical)
|
||||
(lambda (id)
|
||||
(eq? (get-binding id) 'lexical))]
|
||||
[(list 'unbound)
|
||||
(lambda (id)
|
||||
(eq? (get-binding id) #f))]
|
||||
[(list 'binding module-binding)
|
||||
(lambda (id)
|
||||
(let ([binding (get-binding id)])
|
||||
(and (pair? binding)
|
||||
(same-binding? binding module-binding))))]
|
||||
[(list 'symbol=? name)
|
||||
(lambda (id)
|
||||
(eq? (syntax-e id) name))]
|
||||
[(list 'symbol-like rx)
|
||||
(lambda (id)
|
||||
(regexp-match? rx (symbol->string (syntax-e id))))]
|
||||
[(list 'from-kernel-module)
|
||||
(lambda (id)
|
||||
(let ([binding (get-binding id)])
|
||||
(and (pair? binding)
|
||||
(kernel-module? (binding-def-module binding)))))]
|
||||
[(list 'from-def-module module-path)
|
||||
(lambda (id)
|
||||
(let ([binding (get-binding id)])
|
||||
(and (pair? binding)
|
||||
(same-module-path? (binding-def-module binding)
|
||||
module-path))))]
|
||||
[(list 'from-nom-module module-path)
|
||||
(lambda (id)
|
||||
(let ([binding (get-binding id)])
|
||||
(and (pair? binding)
|
||||
(same-module-path? (binding-nom-module binding)
|
||||
module-path))))]
|
||||
[(list 'from-collection collection)
|
||||
(lambda (id)
|
||||
(let ([binding (get-binding id)])
|
||||
(and (pair? binding)
|
||||
(collection-prefix? collection
|
||||
(binding-def-module binding)))))]
|
||||
[(list 'phase>=? num)
|
||||
(lambda (id)
|
||||
(>= (phase) num))]
|
||||
[(cons 'and conditions)
|
||||
(let ([predicates (map condition->predicate conditions)])
|
||||
(lambda (id)
|
||||
(for/and ([predicate predicates])
|
||||
(predicate id))))]
|
||||
[(cons 'or conditions)
|
||||
(let ([predicates (map condition->predicate conditions)])
|
||||
(lambda (id)
|
||||
(for/or ([predicate predicates])
|
||||
(predicate id))))]))
|
||||
|
||||
(define (kernel-module? mpi)
|
||||
(cond [(module-path-index? mpi)
|
||||
(let-values ([(a b) (module-path-index-split mpi)])
|
||||
(match a
|
||||
[`(quote ,name)
|
||||
(regexp-match? #rx"^#%" (symbol->string name))]
|
||||
[_ #f]))]
|
||||
[else #f]))
|
||||
|
||||
;; same-module-path? : mpi mpi -> boolean
|
||||
(define (same-module-path? actual expected)
|
||||
(equal? (module-path-index-resolve actual)
|
||||
(module-path-index-resolve expected)))
|
||||
|
||||
;; same-binding? : binding binding -> boolean
|
||||
(define (same-binding? actual expected)
|
||||
(and (list? actual)
|
||||
(same-module-path? (car actual) (car expected))
|
||||
(eq? (cadr actual) (cadr expected))))
|
||||
|
||||
;; collection-prefix? : (listof string) mpi -> boolean
|
||||
(define (collection-prefix? collection mpi)
|
||||
(define library-frame
|
||||
(expanded-mpi-sexpr->library
|
||||
(mpi-sexpr->expanded-mpi-sexpr
|
||||
(mpi->mpi-sexpr mpi))))
|
||||
(match library-frame
|
||||
[`(LIB ,paths)
|
||||
(let loop ([cpaths collection] [paths paths])
|
||||
(cond [(and (pair? cpaths) (pair? paths))
|
||||
(and (equal? (car cpaths) (car paths))
|
||||
(loop (cdr cpaths) (cdr paths)))]
|
||||
[(pair? cpaths) #f]
|
||||
[(pair? paths) #t]))]
|
||||
[_ #f]))
|
||||
|
||||
|
||||
;; get-binding : id -> binding
|
||||
(define (get-binding id)
|
||||
(identifier-binding id (phase)))
|
||||
|
||||
;; binding-def-module : binding -> module-path
|
||||
(define (binding-def-module binding)
|
||||
(car binding))
|
||||
|
||||
;; binding-def-name : binding -> module-path
|
||||
(define (binding-def-name binding)
|
||||
(cadr binding))
|
||||
|
||||
;; binding-nom-module : binding -> module-path
|
||||
(define (binding-nom-module binding)
|
||||
(caddr binding))
|
||||
|
||||
;; binding-nom-name : binding -> module-path
|
||||
(define (binding-nom-name binding)
|
||||
(cadddr binding))
|
||||
|
||||
|
||||
;; ----
|
||||
|
||||
;; Conversion to and from S-expr form.
|
||||
;; Conversion is lossy (identifier policies)
|
||||
|
||||
;; policy->policy-sexpr
|
||||
(define (policy->policy-sexpr policy)
|
||||
(match policy
|
||||
[`(custom ,b1 ,b2 ,b3 ,b4 ,entries)
|
||||
`(CUSTOM ,b1 ,b2 ,b3 ,b4 ,(map entry->entry-sexpr entries))]
|
||||
[_ policy]))
|
||||
|
||||
;; policy-sexpr->policy
|
||||
(define (policy-sexpr->policy sexpr)
|
||||
(match sexpr
|
||||
[`(CUSTOM ,b1 ,b2 ,b3 ,b4 ,entries)
|
||||
`(custom ,b1 ,b2 ,b3 ,b4 ,(map entry-sexpr->entry entries))]
|
||||
[_ sexpr]))
|
||||
|
||||
;; entry->entry-sexpr
|
||||
(define (entry->entry-sexpr entry)
|
||||
(match entry
|
||||
[`(show-if ,condition)
|
||||
`(show-if ,(condition->condition-sexpr condition))]
|
||||
[`(hide-if ,condition)
|
||||
`(hide-if ,(condition->condition-sexpr condition))]))
|
||||
|
||||
;; entry-sexpr->entry
|
||||
(define (entry-sexpr->entry sexpr)
|
||||
(match sexpr
|
||||
[`(show-if ,condition)
|
||||
`(show-if ,(condition-sexpr->condition condition))]
|
||||
[`(hide-if ,condition)
|
||||
`(hide-if ,(condition-sexpr->condition condition))]))
|
||||
|
||||
;; condition->condition-sexpr
|
||||
(define (condition->condition-sexpr condition)
|
||||
(match condition
|
||||
[(list 'free=? id)
|
||||
(let ([binding (identifier-binding id)])
|
||||
(cond [(list? binding)
|
||||
(condition->condition-sexpr `(binding ,binding))]
|
||||
[(eq? binding 'lexical)
|
||||
`(and (lexical)
|
||||
(symbol=? ,(syntax-e id)))]
|
||||
[else
|
||||
`(and (unbound)
|
||||
(symbol=? ,(syntax-e id)))]))]
|
||||
[`(binding (,mod1 ,name1 ,mod2 ,name2 . ,rest))
|
||||
`(BINDING (,(mpi->mpi-sexpr mod1)
|
||||
,name1
|
||||
,(mpi->mpi-sexpr mod2)
|
||||
,name2
|
||||
. ,rest))]
|
||||
[`(from-def-module ,mod)
|
||||
`(FROM-DEF-MODULE ,(mpi->mpi-sexpr mod))]
|
||||
[`(from-nom-module ,mod)
|
||||
`(FROM-NOM-MODULE ,(mpi->mpi-sexpr mod))]
|
||||
[`(and . ,conditions)
|
||||
`(and ,@(map condition->condition-sexpr conditions))]
|
||||
[`(or . ,conditions)
|
||||
`(or ,@(map condition->condition-sexpr conditions))]
|
||||
[_
|
||||
condition]))
|
||||
|
||||
;; condition-sexpr->condition
|
||||
(define (condition-sexpr->condition sexpr)
|
||||
(match sexpr
|
||||
[`(BINDING (,mod1 ,name1 ,mod2 ,name2 . ,rest))
|
||||
`(binding (,(mpi-sexpr->mpi mod1)
|
||||
,name1
|
||||
,(mpi-sexpr->mpi mod2)
|
||||
,name2
|
||||
. ,rest))]
|
||||
[`(FROM-DEF-MODULE ,mod)
|
||||
`(from-def-module ,(mpi-sexpr->mpi mod))]
|
||||
[`(FROM-NOM-MODULE ,mod)
|
||||
`(from-nom-module ,(mpi-sexpr->mpi mod))]
|
||||
[`(and . ,sexprs)
|
||||
`(and ,@(map condition-sexpr->condition sexprs))]
|
||||
[`(or . ,sexprs)
|
||||
`(or ,@(map condition-sexpr->condition sexprs))]
|
||||
[_ sexpr]))
|
||||
|
||||
|
||||
;; ----
|
||||
|
||||
(provide same-condition?)
|
||||
|
||||
;; same-condition? : condition condition -> boolean
|
||||
(define (same-condition? a b)
|
||||
(and (eq? (car a) (car b))
|
||||
(match a
|
||||
[`(free=? ,aid)
|
||||
(let ([bid (cadr b)])
|
||||
(for/and ([n '(0 #| 1 -1 |#)])
|
||||
(free-identifier=? aid bid n)))]
|
||||
[`(binding ,ab)
|
||||
(let ([bb (cadr b)])
|
||||
(and (same-module-path? (car ab) (car bb))
|
||||
(eq? (cadr ab) (cadr bb))
|
||||
(equal? (list-tail ab 4) (list-tail bb 4))))]
|
||||
[`(from-def-module ,ampi)
|
||||
(same-module-path? ampi (cadr b))]
|
||||
[`(from-nom-module ,ampi)
|
||||
(same-module-path? ampi (cadr b))]
|
||||
[`(and . ,aconditions)
|
||||
(let ([bconditions (cdr b)])
|
||||
(and (= (length aconditions) (length bconditions))
|
||||
(andmap same-condition? aconditions (cdr b))))]
|
||||
[`(or . ,aconditions)
|
||||
(let ([bconditions (cdr b)])
|
||||
(and (= (length aconditions) (length bconditions))
|
||||
(andmap same-condition? aconditions (cdr b))))]
|
||||
[_
|
||||
(equal? a b)])))
|
||||
|
||||
|
||||
;; ----
|
||||
|
||||
(provide standard-policy
|
||||
base-policy
|
||||
hide-all-policy
|
||||
hide-none-policy)
|
||||
|
||||
(define standard-policy
|
||||
#;(make-policy #t #t #t #t null)
|
||||
(policy->predicate 'standard))
|
||||
|
||||
(define base-policy
|
||||
#;(make-policy #t #f #f #f null)
|
||||
(policy->predicate
|
||||
'(custom #t #f #f #f ())))
|
||||
|
||||
(define (hide-all-policy id) #f)
|
||||
(define (hide-none-policy id) #t)
|
||||
|
||||
#|
|
||||
|
||||
;; make-policy : bool^4 (listof (identifier bindinglist (bool -> void) -> void))
|
||||
;; -> identifier -> bool
|
||||
(define (make-policy hide-mzscheme?
|
||||
|
|
@ -47,17 +392,7 @@
|
|||
#f]
|
||||
[else #t]))))
|
||||
|
||||
(define standard-policy
|
||||
(make-policy #t #t #t #t null))
|
||||
|
||||
(define base-policy
|
||||
(make-policy #t #f #f #f null))
|
||||
|
||||
(define (hide-all-policy id) #f)
|
||||
(define (hide-none-policy id) #t)
|
||||
|
||||
|
||||
;;
|
||||
;; ----
|
||||
|
||||
(define (scheme-module? mpi)
|
||||
(let ([abs (find-absolute-module-path mpi)])
|
||||
|
|
@ -102,3 +437,4 @@
|
|||
(define (lib-module-path? mp)
|
||||
(or (symbol? mp)
|
||||
(and (pair? mp) (memq (car mp) '(lib planet)))))
|
||||
|#
|
||||
|
|
@ -1,4 +1,6 @@
|
|||
#lang scheme/base
|
||||
(require scheme/match)
|
||||
|
||||
(provide mpi->list
|
||||
mpi->string)
|
||||
|
||||
|
|
@ -21,3 +23,236 @@
|
|||
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
|
||||
[(null? mps) "this module"]))
|
||||
(format "~s" mpi)))
|
||||
|
||||
;; --
|
||||
|
||||
(provide mpi->mpi-sexpr
|
||||
mpi-sexpr->mpi
|
||||
rmp->rmp-sexpr
|
||||
rmp-sexpr->rmp)
|
||||
|
||||
;; mp = module-path
|
||||
;; mpi = module-path-index
|
||||
;; rmp = resolved-module-path
|
||||
|
||||
;; An mpi-sexpr is one of
|
||||
;; (cons mp-sexpr mpi-sexpr)
|
||||
;; (list rmp-sexpr)
|
||||
;; (list #f) ;; "self" module
|
||||
;; null
|
||||
|
||||
;; mpi->mpi-sexpr : mpi -> mpi-sexpr
|
||||
(define (mpi->mpi-sexpr mpi)
|
||||
(cond [(module-path-index? mpi)
|
||||
(let-values ([(mod next) (module-path-index-split mpi)])
|
||||
(cons mod (mpi->mpi-sexpr next)))]
|
||||
[(resolved-module-path? mpi)
|
||||
(list (rmp->rmp-sexpr mpi))]
|
||||
[else null]))
|
||||
|
||||
;; mpi-sexpr->mpi : mpi-sexpr -> mpi
|
||||
(define (mpi-sexpr->mpi sexpr)
|
||||
(match sexpr
|
||||
['() #f]
|
||||
[(list (list 'resolved path))
|
||||
(rmp-sexpr->rmp path)]
|
||||
[(cons first rest)
|
||||
(module-path-index-join first (mpi-sexpr->mpi rest))]))
|
||||
|
||||
;; rmp->rmp-sexpr : rmp -> rmp-sexpr
|
||||
(define (rmp->rmp-sexpr rmp)
|
||||
(list 'resolved (resolved-module-path-name rmp)))
|
||||
|
||||
;; rmp-sexpr->rmp : rmp-sexpr -> rmp
|
||||
(define (rmp-sexpr->rmp sexpr)
|
||||
(make-resolved-module-path (cadr sexpr)))
|
||||
|
||||
;; ----
|
||||
|
||||
(provide mpi-sexpr->expanded-mpi-sexpr
|
||||
expanded-mpi-sexpr->mpi-sexpr
|
||||
|
||||
mpi-frame->expanded-mpi-frame
|
||||
expanded-mpi-frame->mpi-frame
|
||||
|
||||
expanded-mpi-sexpr->library
|
||||
absolute-expanded-mpi-frame?
|
||||
library-expanded-mpi-frame?)
|
||||
|
||||
;; An expanded-mpi-sexpr is (listof expanded-mpi-frame)
|
||||
|
||||
;; An expanded-mpi-frame is one of:
|
||||
;; (list 'LIB (listof string))
|
||||
;; (list 'PLANET (listof string) PackageSpec)
|
||||
;; (list 'FILE string)
|
||||
;; absolute file path (not relative)
|
||||
;; (list 'QUOTE symbol)
|
||||
;; (list 'SELF)
|
||||
;; (list 'REL (listof string))
|
||||
;; The first 5 variants are considered "absolute" frames.
|
||||
;; The first 2 variants are consider "library" frames.
|
||||
|
||||
;; mpi-sexpr->expanded-mpi-sexpr
|
||||
(define (mpi-sexpr->expanded-mpi-sexpr sexpr)
|
||||
(map mpi-frame->expanded-mpi-frame sexpr))
|
||||
|
||||
;; mpi-frame->expanded-mpi-frame
|
||||
(define (mpi-frame->expanded-mpi-frame sexpr)
|
||||
(match sexpr
|
||||
[#f
|
||||
`(SELF)]
|
||||
[`(quote ,mod)
|
||||
`(QUOTE ,mod)]
|
||||
[`(lib ,path)
|
||||
(cond [(symbol? path)
|
||||
(mpi-frame->expanded-mpi-frame path)]
|
||||
[(regexp-match? #rx"/" path)
|
||||
`(LIB ,(split-mods path))]
|
||||
[else
|
||||
`(LIB ,(list "mzlib" path))])]
|
||||
[`(lib ,path . ,more)
|
||||
`(LIB ,(split-mods path more))]
|
||||
[`(planet ,(? symbol? spec))
|
||||
(mpi-frame->expanded-mpi-frame (parse-planet-spec spec))]
|
||||
[`(planet ,path ,package . ,more)
|
||||
`(PLANET ,(split-mods path more) ,package)]
|
||||
[(? symbol? mod)
|
||||
`(LIB ,(split-mods* (symbol->string mod)))]
|
||||
[`(file ,path)
|
||||
(cond [(absolute-path? path)
|
||||
`(FILE ,path)]
|
||||
[else
|
||||
`(REL (split-mods path))])]
|
||||
[(? string? path)
|
||||
`(REL ,(split-mods path))]))
|
||||
|
||||
;; expanded-mpi-sexpr->mpi-sexpr
|
||||
(define (expanded-mpi-sexpr->mpi-sexpr sexpr)
|
||||
(map expanded-mpi-frame->mpi-frame sexpr))
|
||||
|
||||
;; expanded-mpi-frame->mpi-frame
|
||||
(define (expanded-mpi-frame->mpi-frame sexpr)
|
||||
(match sexpr
|
||||
[`(SELF)
|
||||
#f]
|
||||
[`(QUOTE ,mod)
|
||||
`(quote ,mod)]
|
||||
[`(LIB ,paths)
|
||||
`(lib ,(apply string-append (intersperse "/" paths)))]
|
||||
[`(PLANET ,paths ,package)
|
||||
`(planet ,(apply string-append (intersperse "/" paths)) ,package)]
|
||||
[`(FILE ,path)
|
||||
`(file ,path)]
|
||||
[`(REL ,paths)
|
||||
(apply string-append (intersperse "/" paths))]))
|
||||
|
||||
(define (parse-planet-spec spec-sym)
|
||||
(define spec (symbol->string spec-sym))
|
||||
(let ([m (regexp-match #rx"([^/]*)/([^:/]*)(?:[:]([^/]*))?(?:/(.*))?" spec)])
|
||||
(unless m (error "bad planet symbol" spec-sym))
|
||||
(let ([owner (cadr m)]
|
||||
[package (string-append (caddr m) ".plt")]
|
||||
[version (and (cadddr m) (parse-version (cadddr m)))]
|
||||
[path (list-ref m 4)])
|
||||
`(planet ,(string-append (or path "main") ".ss")
|
||||
(,owner ,package . ,version)))))
|
||||
|
||||
(define (parse-version str)
|
||||
;; FIXME!!!
|
||||
'())
|
||||
|
||||
(define (split-mods* path)
|
||||
(let ([mods (split-mods path)])
|
||||
(if (and (pair? mods) (null? (cdr mods)))
|
||||
(append mods (list "main.ss"))
|
||||
mods)))
|
||||
|
||||
(define (split-mods path [more null])
|
||||
(append (apply append (map split-mods more))
|
||||
(regexp-split #rx"/" path)))
|
||||
|
||||
(define (flatten-mods more path)
|
||||
(path->string (apply build-path (append more (list path)))))
|
||||
|
||||
;; expanded-mpi-sexpr->library : expanded-mpi-sexpr -> expanded-mpi-frame
|
||||
(define (expanded-mpi-sexpr->library sexpr0)
|
||||
(define (abs? link)
|
||||
(and (pair? link) (memq (car link) '(LIB PLANET))))
|
||||
(define (loop stack stacks)
|
||||
(cond [(pair? (cdr stack))
|
||||
(cons (car stack) (loop (cdr stack) stacks))]
|
||||
[(pair? stacks)
|
||||
(unless (eq? 'REL (car (car stacks)))
|
||||
(error 'expanded-mpi-sexpr->library
|
||||
"internal error: absolute frame"))
|
||||
(loop (cadr (car stacks)) (cdr stacks))]
|
||||
[else stack]))
|
||||
(define sexpr1 (reverse (cut-to-absolute sexpr0)))
|
||||
(and (library-expanded-mpi-frame? (car sexpr1))
|
||||
`(,(car (car sexpr1))
|
||||
,(loop (cadr (car sexpr1)) (cdr sexpr1))
|
||||
. ,(cddr (car sexpr1)))))
|
||||
|
||||
;; cut-to-absolute : expanded-mpi-sexpr -> expanded-mpi-sexpr
|
||||
(define (cut-to-absolute sexpr)
|
||||
(cond [(and (pair? sexpr)
|
||||
(absolute-expanded-mpi-frame? (car sexpr)))
|
||||
(list (car sexpr))]
|
||||
[(pair? sexpr)
|
||||
(cons (car sexpr) (cut-to-absolute (cdr sexpr)))]))
|
||||
|
||||
;; absolute-expanded-mpi-frame? : expanded-mpi-frame -> boolean
|
||||
(define (absolute-expanded-mpi-frame? sexpr)
|
||||
(not (memq (car sexpr) '(REL))))
|
||||
|
||||
;; library-expanded-mpi-frame? : expanded-mpi-frame -> boolean
|
||||
(define (library-expanded-mpi-frame? sexpr)
|
||||
(memq (car sexpr) '(LIB PLANET)))
|
||||
|
||||
;; intersperse : X (listof X) -> (listof X)
|
||||
(define (intersperse sep items)
|
||||
(cond [(and (pair? items) (pair? (cdr items)))
|
||||
(cons (car items) (cons sep (intersperse sep (cdr items))))]
|
||||
[else items]))
|
||||
|
||||
|
||||
|
||||
#|
|
||||
(provide mpi->path-list
|
||||
path-list->library-module)
|
||||
|
||||
(define (mpi->path-list mpi)
|
||||
(reverse-to-abs (mpi->mpi-sexpr mpi) null))
|
||||
|
||||
(define (reverse-to-abs paths acc)
|
||||
(match paths
|
||||
['()
|
||||
acc]
|
||||
[#f
|
||||
(cons (list 'SELF) acc)]
|
||||
[(cons `(quote ,mod) rest)
|
||||
(cons `(QUOTE ,mod) acc)]
|
||||
[(cons `(lib ,path) rest)
|
||||
(cond [(symbol? path)
|
||||
(reverse-to-abs (cons path rest) acc)]
|
||||
[(regexp-match? #rx"/" path)
|
||||
(cons `(LIB ,(split-mods path)) acc)]
|
||||
[else
|
||||
(cons `(LIB ,(list "mzlib" path)) acc)])]
|
||||
[(cons `(lib ,path . ,more) rest)
|
||||
(cons `(LIB ,(split-mods path more)) acc)]
|
||||
[(cons `(planet ,(? symbol? spec)) rest)
|
||||
(reverse-to-abs (cons (parse-planet-spec spec) rest) acc)]
|
||||
[(cons `(planet ,path ,package . ,more) rest)
|
||||
(cons `(PLANET ,(split-mods path more) ,package) acc)]
|
||||
[(cons (? symbol? mod) rest)
|
||||
(cons `(LIB ,(split-mods* (symbol->string mod))) acc)]
|
||||
[(cons `(file ,path) rest)
|
||||
(cond [(absolute-path? path)
|
||||
(cons `(FILE ,(split-mods path)) acc)]
|
||||
[else (reverse-to-abs rest (cons (split-mods path) acc))])]
|
||||
[(cons (? string? path) rest)
|
||||
(reverse-to-abs rest (cons (split-mods path) acc))]))
|
||||
|
||||
(provide parse-planet-spec)
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
(define mode:standard "Standard")
|
||||
(define mode:custom "Custom ...")
|
||||
|
||||
|
||||
;; macro-hiding-prefs-widget%
|
||||
(define macro-hiding-prefs-widget%
|
||||
(class object%
|
||||
|
|
@ -32,11 +33,12 @@
|
|||
[hide-contracts? (send box:hide-contracts get-value)]
|
||||
[hide-transformers? (send box:hide-phase1 get-value)]
|
||||
[specialized-policies (get-specialized-policies)])
|
||||
(make-policy hide-mzscheme?
|
||||
hide-libs?
|
||||
hide-contracts?
|
||||
hide-transformers?
|
||||
specialized-policies)))
|
||||
(policy->predicate
|
||||
`(custom ,hide-mzscheme?
|
||||
,hide-libs?
|
||||
,hide-contracts?
|
||||
,hide-transformers?
|
||||
,specialized-policies))))
|
||||
|
||||
(define super-panel
|
||||
(new vertical-panel%
|
||||
|
|
@ -162,12 +164,11 @@
|
|||
(define add-show-id-button
|
||||
(new button% (parent look-button-pane) (label "Show macro") (enabled #f)
|
||||
(callback (lambda _ (add-show-identifier) (refresh)))))
|
||||
#;(new grow-box-spacer-pane% (parent right-pane))
|
||||
;;(new grow-box-spacer-pane% (parent right-pane))
|
||||
|
||||
;; Methods
|
||||
|
||||
(define stx #f)
|
||||
(define stx-name #f)
|
||||
|
||||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
|
|
@ -181,60 +182,42 @@
|
|||
;; set-syntax : syntax/#f -> void
|
||||
(define/public (set-syntax lstx)
|
||||
(set! stx (and (identifier? lstx) lstx))
|
||||
(when (identifier? stx)
|
||||
(let ([binding (identifier-binding stx)])
|
||||
(if (pair? binding)
|
||||
(set! stx-name (cadr binding))
|
||||
(set! stx-name (syntax-e stx)))))
|
||||
(send add-show-id-button enable (identifier? lstx))
|
||||
(send add-hide-id-button enable (identifier? lstx)))
|
||||
|
||||
;; A PolicyLine is an Entry
|
||||
;; Entry is defined in ../model/hiding-policies
|
||||
|
||||
;; identifier-policies : (listof Entry)
|
||||
(define identifier-policies null)
|
||||
|
||||
;; get-specialized-policies : -> (listof Entry)
|
||||
(define/private (get-specialized-policies)
|
||||
(map (lambda (policy)
|
||||
(define key (mcar policy))
|
||||
(define show? (mcdr policy))
|
||||
(cond [(pair? key)
|
||||
(lambda (id binding return)
|
||||
(when (and (pair? binding)
|
||||
(equal? key (get-id-key/binding id binding)))
|
||||
(return show?)))]
|
||||
[else
|
||||
(lambda (id binding return)
|
||||
(when (free-identifier=? id key)
|
||||
(return show?)))]))
|
||||
identifier-policies))
|
||||
identifier-policies)
|
||||
|
||||
(define/public (add-hide-identifier)
|
||||
(add-identifier-policy #f)
|
||||
(ensure-custom-mode))
|
||||
(when (identifier? stx)
|
||||
(add-policy-line 'hide-if `(free=? ,stx))))
|
||||
|
||||
(define/public (add-show-identifier)
|
||||
(add-identifier-policy #t)
|
||||
(when (identifier? stx)
|
||||
(add-policy-line 'show-if `(free=? ,stx))))
|
||||
|
||||
;; add-policy-line : 'show-if/'hide-if Condition -> void
|
||||
(define/private (add-policy-line action condition)
|
||||
(set! identifier-policies
|
||||
(cons `(,action ,condition)
|
||||
(remove-policy/condition condition identifier-policies)))
|
||||
(update-list-view)
|
||||
(ensure-custom-mode))
|
||||
|
||||
(define/private (add-identifier-policy show?)
|
||||
(when (identifier? stx)
|
||||
(let ([key (get-id-key stx)])
|
||||
(let loop ([i 0] [policies identifier-policies])
|
||||
(cond [(null? policies)
|
||||
(set! identifier-policies
|
||||
(cons (mcons key show?) identifier-policies))
|
||||
(send look-ctl append "")
|
||||
(update-list-view i key show?)]
|
||||
[(key=? key (mcar (car policies)))
|
||||
(set-mcdr! (car policies) show?)
|
||||
(update-list-view i key show?)]
|
||||
[else (loop (add1 i) (cdr policies))])))))
|
||||
|
||||
(define/private (update-list-view index key show?)
|
||||
(send look-ctl set-data index key)
|
||||
(send look-ctl set-string
|
||||
index
|
||||
(string-append (if show? "show " "hide ")
|
||||
(key->text key))))
|
||||
;; update-list-view : -> void
|
||||
(define/private (update-list-view)
|
||||
(send look-ctl set null)
|
||||
(for ([policy identifier-policies])
|
||||
(send look-ctl append (policy->string policy) policy)))
|
||||
|
||||
;; delete-selected : -> void
|
||||
(define/private (delete-selected)
|
||||
(define to-delete (sort (send look-ctl get-selections) <))
|
||||
(set! identifier-policies
|
||||
|
|
@ -245,11 +228,70 @@
|
|||
[else
|
||||
(cons (car policies)
|
||||
(loop (add1 i) (cdr policies) to-delete))])))
|
||||
(for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete)))
|
||||
(update-list-view))
|
||||
|
||||
(super-new)
|
||||
(update-visibility)))
|
||||
|
||||
|
||||
(define (remove-policy/condition condition policies)
|
||||
(filter (lambda (p) (not (same-condition? (cadr p) condition)))
|
||||
policies))
|
||||
|
||||
|
||||
;; ----
|
||||
|
||||
(define (policy->string policy)
|
||||
(string-append
|
||||
(case (car policy)
|
||||
((show-if) "show ")
|
||||
((hide-if) "hide "))
|
||||
(condition->string (cadr policy))))
|
||||
|
||||
(define (condition->string condition)
|
||||
(match condition
|
||||
[`(free=? ,id)
|
||||
(let ([b (identifier-binding id)])
|
||||
(or #;(identifier->string id)
|
||||
(cond [(list? b)
|
||||
(let ([mod (caddr b)]
|
||||
[name (cadddr b)])
|
||||
(format "'~s' from ~a" name (mpi->string mod)))]
|
||||
[else
|
||||
(symbol->string (syntax-e id))])))]
|
||||
[_
|
||||
"<condition>"]))
|
||||
|
||||
#|
|
||||
(require scribble/xref
|
||||
scribble/manual-struct
|
||||
setup/xref)
|
||||
|
||||
(define xref-p (delay (load-collections-xref)))
|
||||
|
||||
(define (identifier->string id)
|
||||
(define binding-info (identifier-binding id))
|
||||
(define xref (force xref-p))
|
||||
(define definition-tag
|
||||
(and xref
|
||||
(xref-binding->definition-tag xref binding-info #f)))
|
||||
(and definition-tag
|
||||
(let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)])
|
||||
(define index-entry
|
||||
(and path (xref-tag->index-entry xref definition-tag)))
|
||||
(define desc
|
||||
(and index-entry (entry-desc index-entry)))
|
||||
(and desc
|
||||
(let ([name (exported-index-desc-name desc)]
|
||||
[libs (exported-index-desc-from-libs desc)])
|
||||
(format "'~a' from ~a"
|
||||
name
|
||||
(mpi->string (car libs))))))))
|
||||
|#
|
||||
|
||||
|
||||
|
||||
#|
|
||||
(define (get-id-key id)
|
||||
id
|
||||
#; ;; FIXME
|
||||
|
|
@ -277,4 +319,4 @@
|
|||
name
|
||||
(mpi->string mod)))]
|
||||
[else (symbol->string (syntax-e key))]))
|
||||
|
||||
|#
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user