diff options
author | Michał Masłowski <mtjm@mtjm.eu> | 2012-06-18 14:09:42 +0200 |
---|---|---|
committer | Michał Masłowski <mtjm@mtjm.eu> | 2012-06-18 14:09:42 +0200 |
commit | 0982af0e4b5622aaae02f43925fe1152006f878e (patch) | |
tree | 38f7971d08e822fa0a4ffcb5e432b7da993da497 /extra/racket | |
parent | 38389505b5f8809743855ead04f7feb9a37a9cc8 (diff) | |
parent | 014b5d0a1ee98ba0466f067f605b9637f2a14b2f (diff) |
Merge branch 'master' of ssh://parabolagnulinux.org:1863/home/parabola/abslibre-pre-mips64el
Conflicts:
community/nautilus-actions/PKGBUILD
extra/libdrm/PKGBUILD
extra/mesa/PKGBUILD
extra/perl-dbd-mysql/PKGBUILD
multilib/lib32-freetype2/PKGBUILD
multilib/lib32-krb5/PKGBUILD
multilib/lib32-libdrm/PKGBUILD
multilib/lib32-libdrm/no-pthread-stubs.patch
multilib/lib32-libpng/PKGBUILD
multilib/lib32-mesa/PKGBUILD
multilib/lib32-pango/PKGBUILD
testing/bind/PKGBUILD
testing/dmraid/PKGBUILD
testing/glibc/PKGBUILD
Diffstat (limited to 'extra/racket')
-rw-r--r-- | extra/racket/PKGBUILD | 13 | ||||
-rw-r--r-- | extra/racket/drracket-normal.rkt | 199 |
2 files changed, 208 insertions, 4 deletions
diff --git a/extra/racket/PKGBUILD b/extra/racket/PKGBUILD index 5f1b90ce5..a5db6e3cb 100644 --- a/extra/racket/PKGBUILD +++ b/extra/racket/PKGBUILD @@ -1,9 +1,9 @@ -# $Id: PKGBUILD 157415 2012-04-28 09:27:18Z allan $ +# $Id: PKGBUILD 161957 2012-06-17 01:21:57Z eric $ # Maintainer: Eric Bélanger <eric@archlinux.org> pkgname=racket pkgver=5.2.1 -pkgrel=2 +pkgrel=3 pkgdesc="A programming language environment (formerly known as PLT Scheme) suitable for tasks ranging from scripting to application development" arch=('i686' 'x86_64' 'mips64el') url="http://racket-lang.org/" @@ -13,9 +13,10 @@ makedepends=('gsfonts') options=('!libtool' '!strip') install=racket.install source=(http://download.racket-lang.org/installers/${pkgver}/racket/${pkgname}-${pkgver}-src-unix.tgz \ - drracket.desktop) + drracket.desktop drracket-normal.rkt) sha1sums=('b51cdd8b9825edb60e5c2c80472cec8220918cd1' - 'a20808f6b250225704856f82a544681a962a299d') + 'a20808f6b250225704856f82a544681a962a299d' + '6699e80e424479d45f427ba341003235e0d475cf') build() { cd "${srcdir}/${pkgname}-${pkgver}/src" @@ -27,6 +28,10 @@ build() { package() { cd "${srcdir}/${pkgname}-${pkgver}/src" make DESTDIR="${pkgdir}" install + + # FS#30245 + install -D -m644 "${srcdir}/drracket-normal.rkt" "${pkgdir}/usr/lib/racket/collects/drracket/private/drracket-normal.rkt" + install -D -m644 ../collects/icons/plt.xpm "${pkgdir}/usr/share/pixmaps/drracket.xpm" install -D -m644 "${srcdir}/drracket.desktop" "${pkgdir}/usr/share/applications/drracket.desktop" } diff --git a/extra/racket/drracket-normal.rkt b/extra/racket/drracket-normal.rkt new file mode 100644 index 000000000..5ed11c21c --- /dev/null +++ b/extra/racket/drracket-normal.rkt @@ -0,0 +1,199 @@ +#lang racket/base + +(require mred + racket/class + racket/cmdline + racket/list + framework/private/bday + framework/splash + racket/runtime-path + racket/file + "frame-icon.rkt" + "eb.rkt") + +(define-runtime-path doc-icon.rkt "dock-icon.rkt") + +(define files-to-open (command-line #:args filenames filenames)) + +;; updates the command-line-arguments with only the files +;; to open. See also main.rkt. +(current-command-line-arguments (apply vector files-to-open)) + +(define (currently-the-weekend?) + (define date (seconds->date (current-seconds))) + (define dow (date-week-day date)) + (or (= dow 6) (= dow 0))) + +(define (valentines-day?) + (define date (seconds->date (current-seconds))) + (and (= 2 (date-month date)) + (= 14 (date-day date)))) + +(define (current-icon-state) + (cond + [(valentines-day?) 'valentines] + [(currently-the-weekend?) 'weekend] + [else 'normal])) + +(define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?) + (let* ([date (seconds->date (current-seconds))] + [month (date-month date)] + [day (date-day date)] + [dow (date-week-day date)]) + (values (and (= 3 month) (= 2 day)) + #f + (and (= 6 month) (= 11 day)) + (and (= 10 month) (= 31 day))))) + + +(define special-state #f) + +(define (icons-bitmap name) + (make-object bitmap% (collection-file-path name "icons"))) + +(define-struct magic-image (chars filename [bitmap #:mutable])) + +(define (magic-img str img) + (make-magic-image (reverse (string->list str)) img #f)) + +;; magic strings and their associated images. There should not be a string +;; in this list that is a prefix of another. +(define magic-images + (list #;(magic-img "larval" "PLT-206-larval.png") + (magic-img "mars" "PLT-206-mars.jpg"))) + +(define (load-magic-images) + (set! load-magic-images void) ; run only once + (for-each (λ (magic-image) + (unless (magic-image-bitmap magic-image) + (set-magic-image-bitmap! + magic-image + (icons-bitmap (magic-image-filename magic-image))))) + magic-images)) + +(define longest-magic-string + (apply max (map (λ (s) (length (magic-image-chars s))) magic-images))) + +(define key-codes null) + +(define (find-magic-image) + (define (prefix? l1 l2) + (or (null? l1) + (and (pair? l2) + (eq? (car l1) (car l2)) + (prefix? (cdr l1) (cdr l2))))) + (ormap (λ (i) (and (prefix? (magic-image-chars i) key-codes) i)) + magic-images)) + +(define (add-key-code new-code) + (set! key-codes (cons new-code key-codes)) + (when ((length key-codes) . > . longest-magic-string) + (set! key-codes (take key-codes longest-magic-string)))) + +(define (drracket-splash-char-observer evt) + (let ([ch (send evt get-key-code)]) + (when (and (eq? ch #\q) + (send evt get-control-down)) + (exit)) + (when (char? ch) + ;; as soon as something is typed, load the bitmaps + (load-magic-images) + (add-key-code ch) + (let ([match (find-magic-image)]) + (when match + (set! key-codes null) + (set-splash-bitmap + (if (eq? special-state match) + (begin (set! special-state #f) the-splash-bitmap) + (begin (set! special-state match) + (magic-image-bitmap match)))) + (refresh-splash)))))) + +(when (eb-bday?) (install-eb)) + +(define weekend-bitmap-spec (collection-file-path "plt-logo-red-shiny.png" "icons")) +(define normal-bitmap-spec (collection-file-path "plt-logo-red-diffuse.png" "icons")) +(define valentines-days-spec (collection-file-path "heart.png" "icons")) + +(define the-bitmap-spec + (cond + [(valentines-day?) + valentines-days-spec] + [(or prince-kuhio-day? kamehameha-day?) + (set-splash-progress-bar?! #f) + (let ([size ((dynamic-require 'drracket/private/palaka 'palaka-pattern-size) 4)]) + (vector (dynamic-require 'drracket/private/honu-logo 'draw-honu) + size + size))] + [texas-independence-day? + (collection-file-path "texas-plt-bw.gif" "icons")] + [halloween? + (collection-file-path "PLT-pumpkin.png" "icons")] + [(currently-the-weekend?) + weekend-bitmap-spec] + [else normal-bitmap-spec])) +(define the-splash-bitmap (read-bitmap the-bitmap-spec)) +(set-splash-char-observer drracket-splash-char-observer) + +(when (eq? (system-type) 'macosx) + (define initial-state (current-icon-state)) + (define weekend-bitmap (if (equal? the-bitmap-spec weekend-bitmap-spec) + the-splash-bitmap + #f)) + (define weekday-bitmap (if (equal? the-bitmap-spec normal-bitmap-spec) + the-splash-bitmap + #f)) + (define valentines-bitmap (if (equal? the-bitmap-spec valentines-days-spec) + the-splash-bitmap + #f)) + (define set-doc-tile-bitmap (dynamic-require doc-icon.rkt 'set-dock-tile-bitmap)) + (define (set-icon state) + (case state + [(valentines) + (unless valentines-bitmap (set! valentines-bitmap (read-bitmap valentines-days-spec))) + (set-doc-tile-bitmap valentines-bitmap)] + [(weekend) + (unless weekend-bitmap (set! weekend-bitmap (read-bitmap weekend-bitmap-spec))) + (set-doc-tile-bitmap weekend-bitmap)] + [(normal) + (unless weekday-bitmap (set! weekday-bitmap (read-bitmap normal-bitmap-spec))) + (set-doc-tile-bitmap weekday-bitmap)])) + (set-icon initial-state) + (void + (thread + (λ () + (let loop ([last-state initial-state]) + (sleep 10) + (define next-state (current-icon-state)) + (unless (equal? last-state next-state) + (set-icon next-state)) + (loop next-state)))))) + +(start-splash the-splash-bitmap + "DrRacket" + 700 + #:allow-funny? #t + #:frame-icon todays-icon) + +(when (getenv "PLTDRBREAK") + (printf "PLTDRBREAK: creating break frame\n") (flush-output) + (let ([to-break (eventspace-handler-thread (current-eventspace))]) + (parameterize ([current-eventspace (make-eventspace)]) + (let* ([f (new frame% (label "Break DrRacket"))] + [b (new button% + (label "Break Main Thread") + (callback + (λ (x y) + (break-thread to-break))) + (parent f))] + [b (new button% + (label "Break All Threads") + (callback + (λ (x y) + ((dynamic-require 'drracket/private/key 'break-threads)))) + (parent f))]) + (send f show #t))))) + +(dynamic-require 'drracket/tool-lib #f) +(shutdown-splash) +(close-splash) |