(module tag-reader mzscheme
(require (lib "file.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "pregexp.ss")
(lib "contract.ss")
(lib "struct.ss")
(lib "serialize.ss"))
(define-struct tag (name path line position) #f)
(provide (struct tag (name path line position)))
(define-struct tag-library (all-tags))
(provide/contract (tag-library? (-> any/c boolean?)))
(provide empty-tag-library)
(define empty-tag-library (make-tag-library empty))
(provide/contract (open-tag-library (path-string? . -> . tag-library?)))
(define (open-tag-library filename)
(call-with-input-file filename
(lambda (ip)
(open-tag-library/input-port ip (path-only filename)))))
(provide/contract (open-tag-library/input-port (input-port? path-string? . -> . tag-library?)))
(define (open-tag-library/input-port ip base-directory)
(let* ([all-tags
(foldl
(lambda (index-exp acc)
(match index-exp
[(list id serialized-path line position)
(cons (make-tag id (deserialize serialized-path) line position)
acc)]
[else
(error "Malformed index sexp at: ~a" index-exp)]))
empty
(read ip))]
[all-tags-with-absolute-paths
(map (lambda (t)
(copy-struct
tag t
(tag-path (path->complete-path
(build-path base-directory (tag-path t))))))
all-tags)])
(make-tag-library all-tags-with-absolute-paths)))
(provide/contract (tag-library-lookup (tag-library? string? . -> . (listof tag?))))
(define (tag-library-lookup library query)
(define (case-matters?)
(pregexp-match "[A-Z]" query))
(define (linear-scan tags)
(define query-pattern (if (case-matters?)
(format "^~a" (pregexp-quote query))
(format "^(?i:~a)" (pregexp-quote query))))
(define (name-matches? name)
(pregexp-match query-pattern name))
(filter (lambda (a-tag)
(match a-tag
[(struct tag (name file line position))
(name-matches? name)]))
tags))
(match library
[(struct tag-library (tags))
(linear-scan tags)])))