GitHub PullRequestReviewCommentEvent at 2014-03-10 22:40:40
Repository: racket
Actor: samth
Payload: {"comment":{"url":"https://api.github.com/repos/plt/racket/pulls/comments/10454308","id":10454308,"diff_hunk":"@@ -0,0 +1,318 @@\n+#lang racket/base\n+\n+;; This module provides helper functions for type aliases\n+\n+(require \"../utils/utils.rkt\"\n+         (utils tc-utils)\n+         (env type-alias-env type-name-env)\n+         (rep type-rep)\n+         (private parse-type)\n+         (typecheck internal-forms)\n+         (types resolve base-abbrev)\n+\t data/queue\n+         racket/dict\n+         racket/format\n+         racket/list\n+         racket/match\n+         syntax/id-table\n+         syntax/kerncase\n+         (for-template\n+          (typecheck internal-forms)\n+          racket/base))\n+\n+(provide find-strongly-connected-type-aliases\n+         check-type-alias-contractive\n+         get-type-alias-info\n+         register-all-type-aliases\n+         parse-type-alias)\n+\n+;; A Vertex is a\n+;;   (vertex Identifier Boolean Option<Integer> Option<Integer> Listof<Id>)\n+;;\n+;; interp. a vertex in a graph, we only use this for Tarjan's algorithm\n+;;   id       - identifier (labels vertices)\n+;;   stack?   - whether this vertex is on the stack (for speed)\n+;;   index    - index tracked in Tarjan's algorithm\n+;;   lowlink  - see index\n+;;   adjacent - list of adjacent vertices\n+(struct vertex (id [stack? #:mutable] [index #:mutable]\n+                   [lowlink #:mutable] adjacent)\n+        #:transparent)\n+\n+;; Dict<Id, (List Type Listof<Id>)> -> Listof<Listof<Id>>\n+;; Find strongly connected type aliases in order to\n+;; find mutually recursive aliases\n+;;\n+;; Returns the components in topologically sorted order\n+(define (find-strongly-connected-type-aliases dep-map)\n+  (define vertex-map (make-free-id-table))\n+  (for ([(id adjacent) (in-dict dep-map)])\n+    (free-id-table-set! vertex-map id (vertex id #f #f #f adjacent)))\n+  ;; Implements Tarjan's algorithm. See Wikipedia\n+  ;; http://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm\n+  (define (tarjan vertices)\n+    (define (strongly-connected vtx)\n+      (set-vertex-index! vtx index)\n+      (set-vertex-lowlink! vtx index)\n+      (set! index (add1 index))\n+      (enqueue-front! stack vtx)\n+      (set-vertex-stack?! vtx #t)\n+      (for ([successor-id (in-list (vertex-adjacent vtx))])\n+        (define successor (free-id-table-ref vertices successor-id))\n+        (cond [(not (vertex-index successor))\n+               (strongly-connected successor)\n+               (set-vertex-lowlink! vtx\n+                                    (min (vertex-lowlink vtx)\n+                                         (vertex-lowlink successor)))]\n+              [(vertex-stack? successor)\n+               (set-vertex-lowlink! vtx\n+                                    (min (vertex-lowlink vtx)\n+                                         (vertex-index successor)))]))\n+      ;; sets a result component if this was a root vertex\n+      (when (= (vertex-lowlink vtx) (vertex-index vtx))\n+        (define new-scc\n+          (for/list ([elem (in-queue stack)]\n+                     #:final (equal? vtx elem))\n+            (dequeue! stack)\n+            (set-vertex-stack?! elem #f)\n+            (vertex-id elem)))\n+        (set! sccs (cons new-scc sccs))))\n+\n+    ;; the body\n+    (define index 0)\n+    (define stack (make-queue))\n+    (define sccs '())\n+    (for ([(id vtx) (in-dict vertices)]\n+          #:unless (vertex-index vtx))\n+      (strongly-connected vtx))\n+    sccs)\n+  (tarjan vertex-map))\n+\n+;; check-type-alias-contractive : Id Type -> Void\n+;;\n+;; This function checks if the given type alias is\n+;; \"contractive\" or \"productive\"\n+;;   i.e., that you can unfold a good type like μx.int->x to\n+;;         μx.int->int->int->...x but a type like\n+;;         μx.x only unfolds to itself\n+;;\n+(define (check-type-alias-contractive id type)\n+  (define/match (check type)\n+    [((Union: elems)) (andmap check elems)]\n+    [((Name: name-id _ _ _))\n+     (and (not (free-identifier=? name-id id))\n+          (check (resolve-once type)))]\n+    [((App: rator rands stx))\n+     (and (check rator) (check rands))]\n+    [((Mu: _ body)) (check body)]\n+    [((Poly: names body)) (check body)]\n+    [((PolyDots: names body)) (check body)]\n+    [(_) #t])\n+  (unless (check type)\n+    (tc-error/stx\n+     id\n+     \"Recursive types are not allowed directly inside their definition\")))\n+\n+;; get-type-alias-info : Listof<Syntax> -> Listof<Id> Dict<Id, TypeAliasInfo>\n+;;\n+;; Given the syntaxes representing type alias definitions, return\n+;; the information needed to register them later\n+(define (get-type-alias-info type-aliases)\n+  (for/lists (_1 _2) ([type-alias (in-list type-aliases)])\n+    (define-values (id type-stx args) (parse-type-alias type-alias))\n+    ;; Register type alias names with a dummy value so that it's in\n+    ;; scope for the registration later.\n+    ;;\n+    ;; The `(make-Value (gensym))` expression is used to make sure\n+    ;; that unions don't collapse the aliases too soon.\n+    (register-resolved-type-alias id Err)\n+    (register-type-name\n+     id\n+     (if args\n+         (make-Poly (map syntax-e args) (make-Value (gensym)))\n+         (make-Value (gensym))))\n+    (values id (list id type-stx args))))\n+\n+;; register-all-type-aliases : Listof<Id> Dict<Id, TypeAliasInfo> -> Void\n+;;\n+;; Given parsed type aliases and a type alias map, do the work\n+;; of actually registering the type aliases. If struct names or\n+;; other definitions need to be registered, do that before calling\n+;; this function.\n+(define (register-all-type-aliases type-alias-names type-alias-map)\n+  ;; Disable resolve caching for the extent of this setup.\n+  ;; Makes sure Name types don't get cached too soon.\n+  (current-cache-resolve? #f)\n+\n+  ;; Find type alias dependencies\n+  ;; The two maps defined here contains the dependency structure\n+  ;; of type aliases in two senses:\n+  ;;   (1) other type aliases referenced in a type alias\n+  ;;   (2) other type aliases referenced by some class in a\n+  ;;       type alias in a #:implements clause\n+  ;;\n+  ;; The second is necessary in order to prevent recursive\n+  ;; #:implements clauses and to determine the order in which\n+  ;; recursive type aliases should be initialized.\n+  (define-values (type-alias-dependency-map type-alias-class-map\n+                  type-alias-types)\n+    (for/lists (_1 _2 _3)\n+      ([(name alias-info) (in-dict type-alias-map)])\n+      (define links-box (box null))\n+      (define class-box (box null))\n+      (define type\n+        (parameterize ([current-type-alias-name name]\n+                       [current-referenced-aliases links-box]\n+                       [current-referenced-class-parents class-box])\n+          (parse-type (car alias-info))))\n+      (define pre-dependencies\n+        (remove-duplicates (unbox links-box) free-identifier=?))\n+      (define alias-dependencies\n+        (filter (λ (id) (memf (λ (id2) (free-identifier=? id id2))\n+                              type-alias-names))\n+                pre-dependencies))\n+      (define class-dependencies\n+        (filter (λ (id) (memf (λ (id2) (free-identifier=? id id2))\n+                              type-alias-names))\n+                (unbox class-box)))\n+      (values (cons name alias-dependencies)\n+              (cons name class-dependencies)\n+              type)))\n+\n+  (define components\n+    (find-strongly-connected-type-aliases type-alias-dependency-map))\n+\n+  (define class-components\n+    (find-strongly-connected-type-aliases type-alias-class-map))\n+\n+  ;; helper function for defining singletons\n+  (define (has-self-cycle? component [map type-alias-dependency-map])\n+    (define id (car component))\n+    (memf (λ (id2) (free-identifier=? id id2))\n+          (dict-ref map id)))\n+\n+  ;; A singleton component can be either a self-cycle or a node that\n+  ;; that does not participate in cycles, so we disambiguate\n+  (define-values (acyclic-singletons recursive-aliases)\n+    (for/fold ([singletons '()] [other '()])\n+              ([component (in-list components)])\n+      (if (and (= (length component) 1)\n+               (not (has-self-cycle? component)))\n+          (values (cons (car component) singletons) other)\n+          (values singletons (append component other)))))\n+\n+  ;; Check that no #:implements clauses are recursive\n+  (define counterexample\n+    (for/or ([component class-components])\n+      (and (or (not (= (length component) 1))\n+               (has-self-cycle? component type-alias-class-map))\n+           component)))\n+  (when counterexample\n+    (tc-error/stx\n+     (car counterexample)\n+     \"Recursive #:implements clause not allowed\"))\n+\n+  ;; Split recursive aliases into those involving classes\n+  ;; (in reverse topological order) and the rest of the aliases\n+  (define class-aliases\n+    (for/list ([component (in-list (reverse class-components))]\n+               #:when (member (car component)\n+                              recursive-aliases\n+                              free-identifier=?))\n+      (car component)))\n+  (define other-recursive-aliases\n+    (for/list ([alias (in-list recursive-aliases)]\n+               #:unless (member alias\n+                                class-aliases\n+                                free-identifier=?))\n+      alias))\n+\n+  ;; Reconstruct type alias dependency map based on class parent\n+  ;; information. This ensures that the `deps` field is precise\n+  ;; in all type aliases involving class types\n+  (define (get-all-parent-deps id)\n+    (define (get-deps parent)\n+      (cdr (assoc parent type-alias-dependency-map free-identifier=?)))\n+    (define parents (cdr (assoc id type-alias-class-map free-identifier=?)))\n+    (cond [(null? parents) null]\n+          [else\n+           (define all-deps\n+             (for/list ([parent parents])\n+               (append (get-deps parent)\n+                       (get-all-parent-deps parent))))\n+           (apply append all-deps)]))\n+\n+  (define new-dependency-map/classes\n+    (for/list ([(id deps) (in-dict type-alias-dependency-map)])\n+      (cond [(dict-has-key? type-alias-class-map id)\n+             (define new-deps\n+               (remove-duplicates (append (get-all-parent-deps id) deps)\n+                                  free-identifier=?))\n+             (cons id new-deps)]\n+            [else (cons id deps)])))\n+\n+  ;; Do another pass on dependency map, using the connected\n+  ;; components analysis data to determine which dependencies are\n+  ;; actually needed for mutual recursion. Drop all others.\n+  (define new-dependency-map\n+    (for/list ([(id deps) (in-dict new-dependency-map/classes)])\n+      ;; find the component this `id` participated in so\n+      ;; that we can drop `deps` that aren't in that component\n+      (define component\n+        (findf (λ (component) (member id component free-identifier=?))\n+               components))\n+      (define new-deps\n+        (filter (λ (dep) (member dep component free-identifier=?)) deps))\n+      (cons id new-deps)))\n+\n+  ;; Actually register recursive type aliases\n+  (for ([id (in-list recursive-aliases)])\n+    (define record (dict-ref type-alias-map id))\n+    (match-define (list _ args) record)\n+    (define deps (dict-ref new-dependency-map id))\n+    (register-resolved-type-alias id (make-Name id deps args #f)))\n+\n+  ;; Register non-recursive type aliases\n+  ;;\n+  ;; Note that the connected component algorithm returns results\n+  ;; in topologically sorted order, so we want to go through in the\n+  ;; reverse order of that to avoid unbound type aliases.\n+  (for ([id (in-list acyclic-singletons)])\n+    (define type-stx (car (dict-ref type-alias-map id)))\n+    (register-resolved-type-alias id (parse-type type-stx)))\n+\n+  ;; Finish registering recursive aliases\n+  (define-values (names-to-refine types-to-refine tvarss)\n+    (for/lists (_1 _2 _3)\n+               ([id (in-list (append other-recursive-aliases class-aliases))])\n+      (define record (dict-ref type-alias-map id))\n+      (match-define (list type-stx args) record)\n+      (define type\n+        ;; make sure to reject the type if it uses polymorphic\n+        ;; recursion (see resolve.rkt)\n+        (parameterize ([current-check-polymorphic-recursion args])\n+          (parse-type type-stx)))\n+      (register-type-name id type)\n+      (add-constant-variance! id args)\n+      (check-type-alias-contractive id type)\n+      (values id type args)))\n+\n+  ;; Finally, do a last pass to refine the variance\n+  (refine-variance! names-to-refine types-to-refine tvarss)\n+  (current-cache-resolve? #t))","path":"pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt","position":302,"original_position":302,"commit_id":"d9971d84271ae226f503a98fdb0948a65f66bde5","original_commit_id":"d9971d84271ae226f503a98fdb0948a65f66bde5","user":{"login":"samth","id":244723,"avatar_url":"https://gravatar.com/avatar/83ddd182088d107264f567d1669103b4?d=https%3A%2F%2Fidenticons.github.com%2F98c4c39218e05d91b6576b57cc8fa2d9.png&r=x","gravatar_id":"83ddd182088d107264f567d1669103b4","url":"https://api.github.com/users/samth","html_url":"https://github.com/samth","followers_url":"https://api.github.com/users/samth/followers","following_url":"https://api.github.com/users/samth/following{/other_user}","gists_url":"https://api.github.com/users/samth/gists{/gist_id}","starred_url":"https://api.github.com/users/samth/starred{/owner}{/repo}","subscriptions_url":"https://api.github.com/users/samth/subscriptions","organizations_url":"https://api.github.com/users/samth/orgs","repos_url":"https://api.github.com/users/samth/repos","events_url":"https://api.github.com/users/samth/events{/privacy}","received_events_url":"https://api.github.com/users/samth/received_events","type":"User","site_admin":false},"body":"See `parameterize` comment at the top.","created_at":"2014-03-10T22:40:40Z","updated_at":"2014-03-10T22:40:40Z","html_url":"https://github.com/plt/racket/pull/570#discussion_r10454308","pull_request_url":"https://api.github.com/repos/plt/racket/pulls/570","_links":{"self":{"href":"https://api.github.com/repos/plt/racket/pulls/comments/10454308"},"html":{"href":"https://github.com/plt/racket/pull/570#discussion_r10454308"},"pull_request":{"href":"https://api.github.com/repos/plt/racket/pulls/570"}}}}