hiding-policies.rkt (11065B)
1 #lang racket/base 2 (require racket/match 3 "reductions-config.rkt" 4 "../util/mpi.rkt") 5 (provide policy->predicate) 6 7 ;; A Policy is one of 8 ;; 'disable 9 ;; 'standard 10 ;; (list 'custom boolean boolean boolean boolean (listof Entry)) 11 12 ;; An Entry is one of 13 ;; (list 'show-if Condition) 14 ;; (list 'hide-if Condition) 15 16 ;; A Condition is one of: 17 ;; (list 'free=? identifier) 18 ;; (list 'lexical) 19 ;; (list 'unbound) 20 ;; (list 'binding IdentifierBinding) 21 ;; (list 'symbol=? symbol) 22 ;; (list 'symbol-like regexp) 23 ;; (list 'from-kernel-module) 24 ;; (list 'from-def-module ModulePath) 25 ;; (list 'from-nom-module ModulePath) 26 ;; (list 'from-collection (listof String)) 27 ;; (list 'from-planet-collection String/#f String/#f (listof String)) 28 ;; (list 'phase>=? nat) 29 ;; (cons 'and Condition) 30 ;; (cons 'or Condition) 31 32 ;; policy->predicate 33 (define (policy->predicate policy) 34 (define fun (policy->function policy)) 35 (lambda (id) 36 (case (fun id) 37 [(show) #t] 38 [(hide) #f] 39 [else (error 'policy->predicate "incomplete policy (returned ~s): ~s" 40 (fun id) 41 policy)]))) 42 43 ;; policy->function : Policy -> (id -> choice) 44 (define (policy->function policy) 45 (match policy 46 ['disable 47 (lambda (id) 'show)] 48 ['standard 49 (policy->function '(custom #t #t #t #t ()))] 50 [(list 'custom hide-racket? hide-libs? hide-contracts? hide-phase1? entries) 51 (entries->function entries 52 (policy-base->function hide-racket? 53 hide-libs? 54 hide-contracts? 55 hide-phase1?))])) 56 57 ;; policy-base->function : boolean boolean boolean boolean -> (id -> choice) 58 (define (policy-base->function hide-racket? hide-libs? hide-contracts? hide-phase1?) 59 (entries->function 60 `[(hide-if 61 (or ,@(filter values 62 (list (and hide-racket? 63 '(or (from-kernel-module) 64 (from-collection ("racket")))) 65 (and hide-libs? 66 '(or (from-collection ()) 67 #|(from-planet-collection #f #f ())|#)) 68 (and hide-contracts? 69 '(symbol-like #rx"^provide/contract-id-")) 70 (and hide-phase1? 71 '(phase>=? 1))))))] 72 (lambda (id) 'show))) 73 74 ;; entries->function : (listof Entry) (id -> choice) -> (id -> choice) 75 (define (entries->function entries base-fun) 76 (if (pair? entries) 77 (entry->function (car entries) 78 (entries->function (cdr entries) base-fun)) 79 base-fun)) 80 81 ;; entry->function : Entry -> (id -> choice) 82 (define (entry->function entry base-fun) 83 (match entry 84 [(list 'show-if condition) 85 (let ([pred (condition->predicate condition)]) 86 (lambda (id) 87 (if (pred id) 'show (base-fun id))))] 88 [(list 'hide-if condition) 89 (let ([pred (condition->predicate condition)]) 90 (lambda (id) 91 (if (pred id) 'hide (base-fun id))))] 92 [(list 'splice entries) 93 (entries->function entries base-fun)])) 94 95 ;; condition->predicate : condition -> (id -> boolean) 96 (define (condition->predicate condition) 97 (match condition 98 [(list 'free=? the-id) 99 (lambda (id) 100 (free-identifier=? id the-id (phase)))] 101 [(list 'lexical) 102 (lambda (id) 103 (eq? (get-binding id) 'lexical))] 104 [(list 'unbound) 105 (lambda (id) 106 (eq? (get-binding id) #f))] 107 [(list 'binding module-binding) 108 (lambda (id) 109 (let ([binding (get-binding id)]) 110 (and (pair? binding) 111 (same-binding? binding module-binding))))] 112 [(list 'symbol=? name) 113 (lambda (id) 114 (eq? (syntax-e id) name))] 115 [(list 'symbol-like rx) 116 (lambda (id) 117 (regexp-match? rx (symbol->string (syntax-e id))))] 118 [(list 'from-kernel-module) 119 (lambda (id) 120 (let ([binding (get-binding id)]) 121 (and (pair? binding) 122 (kernel-module? (binding-def-module binding)))))] 123 [(list 'from-def-module module-path) 124 (lambda (id) 125 (let ([binding (get-binding id)]) 126 (and (pair? binding) 127 (same-module-path? (binding-def-module binding) 128 module-path))))] 129 [(list 'from-nom-module module-path) 130 (lambda (id) 131 (let ([binding (get-binding id)]) 132 (and (pair? binding) 133 (same-module-path? (binding-nom-module binding) 134 module-path))))] 135 [(list 'from-collection collection) 136 (lambda (id) 137 (let ([binding (get-binding id)]) 138 (and (pair? binding) 139 (collection-prefix? collection 140 (binding-def-module binding)))))] 141 [(list 'phase>=? num) 142 (lambda (id) 143 (>= (phase) num))] 144 [(cons 'and conditions) 145 (let ([predicates (map condition->predicate conditions)]) 146 (lambda (id) 147 (for/and ([predicate predicates]) 148 (predicate id))))] 149 [(cons 'or conditions) 150 (let ([predicates (map condition->predicate conditions)]) 151 (lambda (id) 152 (for/or ([predicate predicates]) 153 (predicate id))))])) 154 155 (define (kernel-module? mpi) 156 (cond [(module-path-index? mpi) 157 (let-values ([(a b) (module-path-index-split mpi)]) 158 (match a 159 [`(quote ,name) 160 (regexp-match? #rx"^#%" (symbol->string name))] 161 [_ #f]))] 162 [else #f])) 163 164 ;; same-module-path? : mpi mpi -> boolean 165 (define (same-module-path? actual expected) 166 (equal? (module-path-index-resolve actual) 167 (module-path-index-resolve expected))) 168 169 ;; same-binding? : binding binding -> boolean 170 (define (same-binding? actual expected) 171 (and (list? actual) 172 (same-module-path? (car actual) (car expected)) 173 (eq? (cadr actual) (cadr expected)))) 174 175 ;; collection-prefix? : (listof string) mpi -> boolean 176 (define (collection-prefix? collection mpi) 177 (define library-frame 178 (expanded-mpi-sexpr->library 179 (mpi-sexpr->expanded-mpi-sexpr 180 (mpi->mpi-sexpr mpi)))) 181 (match library-frame 182 [`(LIB ,paths) 183 (let loop ([cpaths collection] [paths paths]) 184 (cond [(and (pair? cpaths) (pair? paths)) 185 (and (equal? (car cpaths) (car paths)) 186 (loop (cdr cpaths) (cdr paths)))] 187 [(pair? cpaths) #f] 188 [(pair? paths) #t]))] 189 [_ #f])) 190 191 192 ;; get-binding : id -> binding 193 (define (get-binding id) 194 (identifier-binding id (phase))) 195 196 ;; binding-def-module : binding -> module-path 197 (define (binding-def-module binding) 198 (car binding)) 199 200 ;; binding-def-name : binding -> module-path 201 (define (binding-def-name binding) 202 (cadr binding)) 203 204 ;; binding-nom-module : binding -> module-path 205 (define (binding-nom-module binding) 206 (caddr binding)) 207 208 ;; binding-nom-name : binding -> module-path 209 (define (binding-nom-name binding) 210 (cadddr binding)) 211 212 213 ;; ---- 214 215 ;; Conversion to and from S-expr form. 216 ;; Conversion is lossy (identifier policies) 217 218 ;; policy->policy-sexpr 219 (define (policy->policy-sexpr policy) 220 (match policy 221 [`(custom ,b1 ,b2 ,b3 ,b4 ,entries) 222 `(CUSTOM ,b1 ,b2 ,b3 ,b4 ,(map entry->entry-sexpr entries))] 223 [_ policy])) 224 225 ;; policy-sexpr->policy 226 (define (policy-sexpr->policy sexpr) 227 (match sexpr 228 [`(CUSTOM ,b1 ,b2 ,b3 ,b4 ,entries) 229 `(custom ,b1 ,b2 ,b3 ,b4 ,(map entry-sexpr->entry entries))] 230 [_ sexpr])) 231 232 ;; entry->entry-sexpr 233 (define (entry->entry-sexpr entry) 234 (match entry 235 [`(show-if ,condition) 236 `(show-if ,(condition->condition-sexpr condition))] 237 [`(hide-if ,condition) 238 `(hide-if ,(condition->condition-sexpr condition))])) 239 240 ;; entry-sexpr->entry 241 (define (entry-sexpr->entry sexpr) 242 (match sexpr 243 [`(show-if ,condition) 244 `(show-if ,(condition-sexpr->condition condition))] 245 [`(hide-if ,condition) 246 `(hide-if ,(condition-sexpr->condition condition))])) 247 248 ;; condition->condition-sexpr 249 (define (condition->condition-sexpr condition) 250 (match condition 251 [(list 'free=? id) 252 (let ([binding (identifier-binding id)]) 253 (cond [(list? binding) 254 (condition->condition-sexpr `(binding ,binding))] 255 [(eq? binding 'lexical) 256 `(and (lexical) 257 (symbol=? ,(syntax-e id)))] 258 [else 259 `(and (unbound) 260 (symbol=? ,(syntax-e id)))]))] 261 [`(binding (,mod1 ,name1 ,mod2 ,name2 . ,rest)) 262 `(BINDING (,(mpi->mpi-sexpr mod1) 263 ,name1 264 ,(mpi->mpi-sexpr mod2) 265 ,name2 266 . ,rest))] 267 [`(from-def-module ,mod) 268 `(FROM-DEF-MODULE ,(mpi->mpi-sexpr mod))] 269 [`(from-nom-module ,mod) 270 `(FROM-NOM-MODULE ,(mpi->mpi-sexpr mod))] 271 [`(and . ,conditions) 272 `(and ,@(map condition->condition-sexpr conditions))] 273 [`(or . ,conditions) 274 `(or ,@(map condition->condition-sexpr conditions))] 275 [_ 276 condition])) 277 278 ;; condition-sexpr->condition 279 (define (condition-sexpr->condition sexpr) 280 (match sexpr 281 [`(BINDING (,mod1 ,name1 ,mod2 ,name2 . ,rest)) 282 `(binding (,(mpi-sexpr->mpi mod1) 283 ,name1 284 ,(mpi-sexpr->mpi mod2) 285 ,name2 286 . ,rest))] 287 [`(FROM-DEF-MODULE ,mod) 288 `(from-def-module ,(mpi-sexpr->mpi mod))] 289 [`(FROM-NOM-MODULE ,mod) 290 `(from-nom-module ,(mpi-sexpr->mpi mod))] 291 [`(and . ,sexprs) 292 `(and ,@(map condition-sexpr->condition sexprs))] 293 [`(or . ,sexprs) 294 `(or ,@(map condition-sexpr->condition sexprs))] 295 [_ sexpr])) 296 297 298 ;; ---- 299 300 (provide same-condition?) 301 302 ;; same-condition? : condition condition -> boolean 303 (define (same-condition? a b) 304 (and (eq? (car a) (car b)) 305 (match a 306 [`(free=? ,aid) 307 (let ([bid (cadr b)]) 308 (for/and ([n '(0 #| 1 -1 |#)]) 309 (free-identifier=? aid bid n)))] 310 [`(binding ,ab) 311 (let ([bb (cadr b)]) 312 (and (same-module-path? (car ab) (car bb)) 313 (eq? (cadr ab) (cadr bb)) 314 (equal? (list-tail ab 4) (list-tail bb 4))))] 315 [`(from-def-module ,ampi) 316 (same-module-path? ampi (cadr b))] 317 [`(from-nom-module ,ampi) 318 (same-module-path? ampi (cadr b))] 319 [`(and . ,aconditions) 320 (let ([bconditions (cdr b)]) 321 (and (= (length aconditions) (length bconditions)) 322 (andmap same-condition? aconditions (cdr b))))] 323 [`(or . ,aconditions) 324 (let ([bconditions (cdr b)]) 325 (and (= (length aconditions) (length bconditions)) 326 (andmap same-condition? aconditions (cdr b))))] 327 [_ 328 (equal? a b)]))) 329 330 331 ;; ---- 332 333 (provide standard-policy 334 base-policy 335 hide-all-policy 336 hide-none-policy) 337 338 (define standard-policy 339 (policy->predicate 'standard)) 340 341 (define base-policy 342 (policy->predicate 343 '(custom #t #f #f #f ()))) 344 345 (define (hide-all-policy id) #f) 346 (define (hide-none-policy id) #t)