From 39e0f6aecddecdf2d9fa37f0bffeca46402b9106 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 14 Apr 2015 23:02:39 -0500
Subject: [PATCH] add some tag predicates and tag manipulation functions

---
 scribble-doc/scribblings/scribble/tag.scrbl | 35 +++++++++++++++++++++
 scribble-lib/scribble/tag.rkt               | 21 ++++++++++++-
 2 files changed, 55 insertions(+), 1 deletion(-)

diff --git a/scribble-doc/scribblings/scribble/tag.scrbl b/scribble-doc/scribblings/scribble/tag.scrbl
index 1153c52f..df77cbfa 100644
--- a/scribble-doc/scribblings/scribble/tag.scrbl
+++ b/scribble-doc/scribblings/scribble/tag.scrbl
@@ -89,3 +89,38 @@ Returns a value that is @racket[equal?] to @racket[v], where multiple
 calls to @racket[intern-taglet] for @racket[equal?] @racket[v]s
 produce the same (i.e., @racket[eq?]) value.}
 
+
+@defproc[(definition-tag->class/interface-tag [definition-tag definition-tag?])
+         class/interface-tag?]{
+  Constructs a tag like @racket[definition-tag], except that
+  it matches documentation for the class. If @racket[definition-tag]
+  doesn't document a class or interface, this function still returns
+  the tag that the class or interface documentation would have had,
+  as if @racket[definition-tag] had documented a class or interface.
+}
+@defproc[(class/interface-tag->constructor-tag [class/interface-tag class/interface-tag?])
+         constructor-tag?]{
+  Constructs a tag like @racket[definition-tag], except that
+  it matches documentation for the constructor of the class.
+}
+@defproc[(get-class/interface-and-method [method-tag method-tag?])
+         (values symbol? symbol?)]{
+  Returns the class name and method name (respectively) for the method documented
+  by the docs at @racket[method-tag].
+}
+@defproc[(definition-tag? [v any/c]) boolean?]{
+ Recognizes definition tags. If @racket[(definition-tag? _v)] is
+ @racket[#t], then so is @racket[(tag? _v)].
+}                               
+@defproc[(class/interface-tag? [v any/c]) boolean?]{
+ Recognizes class or interface tags. If @racket[(class/interface-tag? _v)] is
+ @racket[#t], then so is @racket[(tag? _v)].
+}
+@defproc[(method-tag? [v any/c]) boolean?]{
+ Recognizes method tags. If @racket[(method-tag? _v)] is
+ @racket[#t], then so is @racket[(tag? _v)].
+}
+@defproc[(constructor-tag? [v any/c]) boolean?]{
+ Recognizes class constructor tags. If @racket[(constructor-tag? _v)] is
+ @racket[#t], then so is @racket[(tag? _v)].
+}
diff --git a/scribble-lib/scribble/tag.rkt b/scribble-lib/scribble/tag.rkt
index 1ed133e8..3d2c4eef 100644
--- a/scribble-lib/scribble/tag.rkt
+++ b/scribble-lib/scribble/tag.rkt
@@ -3,6 +3,7 @@
          syntax/modcollapse
          setup/collects
          scribble/core
+         racket/match
          ;; Needed to normalize planet version numbers:
          (only-in planet/resolver get-planet-module-path/pkg)
          (only-in planet/private/data pkg-maj pkg-min))
@@ -21,7 +22,15 @@
   [intern-taglet (any/c . -> . any/c)]
   [doc-prefix (case->
                ((or/c #f module-path?) taglet? . -> . taglet?)
-               ((or/c #f module-path?) (or/c #f (listof string?)) taglet? . -> . taglet?))]))
+               ((or/c #f module-path?) (or/c #f (listof string?)) taglet? . -> . taglet?))]
+  [definition-tag->class/interface-tag (-> definition-tag? class/interface-tag?)]
+  [class/interface-tag->constructor-tag (-> class/interface-tag? constructor-tag?)]
+  [get-class/interface-and-method (-> method-tag? (values symbol? symbol?))]
+  [definition-tag? (-> any/c boolean?)]
+  [class/interface-tag? (-> any/c boolean?)]
+  [method-tag? (-> any/c boolean?)]
+  [constructor-tag? (-> any/c boolean?)]))
+
 
 (define (make-section-tag s #:doc [doc #f] #:tag-prefixes [prefix #f])
   `(part ,(doc-prefix doc prefix s)))
@@ -111,3 +120,13 @@
                                            (list s)))
                         s))]))
 
+(define (definition-tag->class/interface-tag t) (cons 'class/intf (cdr t)))
+(define (class/interface-tag->constructor-tag t) (cons 'constructor (cdr t)))
+(define (get-class/interface-and-method meth-tag)
+  (match meth-tag
+    [`(meth ((,_ ,class/interface) ,method))
+     (values class/interface method)]))
+(define (definition-tag? x) (and (tag? x) (equal? (car x) 'def)))
+(define (class/interface-tag? x) (and (tag? x) (equal? (car x) 'class/intf)))
+(define (method-tag? x) (and (tag? x) (equal? (car x) 'meth)))
+(define (constructor-tag? x) (and (tag? x) (equal? (car x) 'constructor)))