120 lines
4 KiB
Racket
120 lines
4 KiB
Racket
#lang at-exp racket/base
|
|
|
|
(require (only-in help/help-utils find-help)
|
|
(only-in help/search perform-search)
|
|
net/url
|
|
racket/contract
|
|
racket/match
|
|
racket/port
|
|
(only-in "../scribble.rkt" binding->path+anchor))
|
|
|
|
(provide doc)
|
|
|
|
(define/contract (doc str)
|
|
(-> string? any)
|
|
(or (identifier-help (namespace-symbol->identifier (string->symbol str)))
|
|
(perform-search str)))
|
|
|
|
;; It is 2017 therefore it is hard to activate a web browser and show
|
|
;; an anchor link within a local HTML file.
|
|
;;
|
|
;; 1. On macOS `find-help` suffers from the fact that `send-url/file`
|
|
;; doesn't supply a `browser` arg to `send-url/mac`. This causes it
|
|
;; to give an "open location" command to osascript. This causes
|
|
;; macOS to ignore #anchor fragments in the URL. Although the
|
|
;; correct page will open, it won't be scrolled to the item of
|
|
;; interest.
|
|
;;
|
|
;; 2. Furthermore, `send-url/mac` doesn't use an "activate" command to
|
|
;; show the browser window (it might be hidden behind Emacs).
|
|
;;
|
|
;; Let's pretend it's 2020. If we we're on mac and can determine the
|
|
;; default browser (from plist files^1), do the equivalent of
|
|
;; `send-url/mac` but with both desired behaviors.
|
|
;;
|
|
;; ^1: This is kludgy because the plist has "bundle IDs" like
|
|
;; "com.google.chrome" but osascript wants strings like "chrome".
|
|
|
|
(module mac-default-browser racket/base
|
|
(require json
|
|
racket/match
|
|
racket/file
|
|
racket/system)
|
|
(provide mac-default-browser)
|
|
|
|
(define launch-plists
|
|
'("Library/Preferences/com.apple.LaunchServices/com.apple.launchservices.secure.plist"
|
|
"Library/Preferences/com.apple.LaunchServices.plist"))
|
|
|
|
(define (mac-default-browser)
|
|
(and (equal? (system-type) 'macosx)
|
|
(for/or ([plist launch-plists])
|
|
(match (mac-http-handler (build-path (find-system-path 'home-dir) plist))
|
|
[#f #f]
|
|
[(pregexp "^.+\\.(.+?)$" ;after final dot
|
|
(list _ s)) s]))))
|
|
|
|
(define (mac-http-handler plist-path) ;; path? -> (or/c string? #f)
|
|
(for/or ([h (in-list (hash-ref (read-bplist plist-path) 'LSHandlers '()))])
|
|
(and (equal? (hash-ref h 'LSHandlerURLScheme #f) "http")
|
|
(hash-ref h 'LSHandlerRoleAll #f))))
|
|
|
|
(define plutil (find-executable-path "plutil" #f))
|
|
|
|
(define (read-bplist plist-path) ;path? -> json?
|
|
(define out-path (make-temporary-file))
|
|
(begin0
|
|
(if (system* plutil
|
|
"-convert" "json"
|
|
"-o" out-path
|
|
plist-path)
|
|
(with-input-from-file out-path read-json)
|
|
(make-hash))
|
|
(delete-file out-path))))
|
|
|
|
(module browse-file-url/mac racket/base
|
|
(provide browse-file-url/mac)
|
|
(require racket/format
|
|
racket/system)
|
|
|
|
(define osascript (find-executable-path "osascript" #f))
|
|
|
|
(define (browse-file-url/mac file-url browser)
|
|
;; Note: Unlike `send-url/mac`, we also do an "activate" to show
|
|
;; the browser window.
|
|
(system*
|
|
osascript
|
|
"-e"
|
|
@~a{tell application "@browser" to open location "@file-url" activate})))
|
|
|
|
(require 'mac-default-browser
|
|
'browse-file-url/mac)
|
|
|
|
|
|
(define/contract (identifier-help stx)
|
|
(-> identifier? boolean?)
|
|
((if (mac-default-browser)
|
|
identifier-help/mac
|
|
identifier-help/other)
|
|
stx))
|
|
|
|
(define/contract (identifier-help/other stx)
|
|
(-> identifier? boolean?)
|
|
;; Like `find-help` but returns whether help was found and shown.
|
|
;; That way, if this returns #f caller knows it could next call
|
|
;; `perform-search` as Plan B.
|
|
(with-handlers ([exn:fail? (λ _ #f)])
|
|
(match (with-output-to-string (λ () (find-help stx)))
|
|
[(pregexp "Sending to web browser") #t]
|
|
[_ #f])))
|
|
|
|
(define/contract (identifier-help/mac stx)
|
|
(-> identifier? boolean?)
|
|
(define-values (path anchor) (binding->path+anchor stx))
|
|
(and path
|
|
anchor
|
|
(let ([path-url (path->url (path->complete-path path))])
|
|
(browse-file-url/mac
|
|
(url->string (struct-copy url path-url [fragment anchor]))
|
|
(mac-default-browser)))
|
|
#t))
|