├── .gitignore ├── LICENSE ├── Makefile.am ├── README.md ├── autogen.sh ├── bin ├── Makefile.am ├── count-lines ├── env.in ├── namespace-markup.in ├── warn-notangle.in └── wrapper.in ├── configure.ac ├── example ├── .gitignore └── Makefile.am ├── src ├── Makefile.am ├── convenience-lambda.scm ├── cursor-list.scm ├── emacsy │ ├── Makefile.am │ ├── advice.nw │ ├── agenda.scm │ ├── block.nw │ ├── buffer.nw │ ├── command.nw │ ├── core.nw │ ├── coroutine-test.scm │ ├── coroutine.scm │ ├── emacsy-c-api.nw │ ├── emacsy.nw │ ├── event.nw │ ├── help.nw │ ├── job-test.scm │ ├── job.scm │ ├── kbd-macro.nw │ ├── keymap.nw │ ├── klecl.nw │ ├── minibuffer.nw │ ├── mode.nw │ ├── mode.scm │ ├── mru-stack.nw │ ├── self-doc.nw │ ├── util.nw │ ├── window.nw │ └── windows.nw └── line-pragma.nw ├── support ├── automake │ ├── guile.am │ └── noweb.am ├── images │ ├── child-window-diagram.graffle │ ├── child-window-diagram.pdf │ ├── emacsy-logo.pdf │ ├── screenshot-small.png │ ├── screenshot.png │ ├── the-garden.pdf │ ├── window-diagram.graffle │ └── window-diagram.pdf ├── latex │ ├── cleveref.sty │ ├── commands.tex │ ├── hello-emacsy.tex │ ├── noweb.sty │ └── nwmac.tex ├── m4 │ ├── ax_check_noweb.m4 │ ├── ax_check_open.m4 │ └── ax_lang_compiler_ms.m4 ├── noweb │ ├── boiler-plate.nw │ ├── paper-footer.nw │ ├── paper-header.nw │ └── paper-wrapper.nw ├── pkg-config │ ├── Makefile.am │ ├── emacsy.pc.in │ └── not-installed │ │ └── emacsy.pc.in └── scheme │ ├── check.scm │ ├── float-equality.scm │ └── srfi │ └── srfi-64.scm ├── test ├── Makefile.am ├── dummy.sh ├── minibuffer-test-dir │ ├── bin │ │ └── run-test │ ├── empty-dir │ │ └── .dummy │ ├── exam │ │ └── .dummy │ ├── minibuffer-a │ └── minibuffer-b ├── print-install.sh.in └── works-without-noweb.sh.in └── todo.org /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | Makefile.in 3 | *.go 4 | *.defs 5 | *.trs 6 | .libs* 7 | .deps* 8 | TAGS 9 | /aclocal.m4 10 | /autom4te.cache/* 11 | /bin/env 12 | /bin/namespace-markup 13 | /bin/runtests 14 | /bin/warn-notangle 15 | /src/stamp-h1 16 | /support/build-aux/config.guess 17 | /support/build-aux/config.sub 18 | /support/build-aux/depcomp 19 | /support/build-aux/install-sh 20 | /support/build-aux/ltmain.sh 21 | /support/build-aux/missing 22 | /support/build-aux/test-driver 23 | /support/m4/libtool.m4 24 | /support/m4/ltoptions.m4 25 | /support/m4/ltsugar.m4 26 | /support/m4/ltversion.m4 27 | /support/m4/lt~obsolete.m4 28 | /support/pkg-config/emacsy.pc 29 | /support/pkg-config/not-installed/emacsy.pc 30 | /test/print-install.sh 31 | /test/works-without-noweb.sh 32 | /src/config.h 33 | /src/config.h.in 34 | /src/emacsy/advice-test.scm 35 | /src/emacsy/advice.scm 36 | /src/emacsy/advice.tex 37 | /src/emacsy/block-test.scm 38 | /src/emacsy/block.scm 39 | /src/emacsy/block.tex 40 | /src/emacsy/buffer-test.scm 41 | /src/emacsy/buffer.scm 42 | /src/emacsy/buffer.tex 43 | /src/emacsy/command-test.scm 44 | /src/emacsy/command.scm 45 | /src/emacsy/command.tex 46 | /src/emacsy/core-test.scm 47 | /src/emacsy/core.scm 48 | /src/emacsy/core.tex 49 | /src/emacsy/emacsy-c-api.tex 50 | /src/emacsy/emacsy-test.scm 51 | /src/emacsy/emacsy.aux 52 | /src/emacsy/emacsy.c 53 | /src/emacsy/emacsy.h 54 | /src/emacsy/emacsy.lo 55 | /src/emacsy/emacsy.log 56 | /src/emacsy/emacsy.nwi 57 | /src/emacsy/emacsy.out 58 | /src/emacsy/emacsy.pdf 59 | /src/emacsy/emacsy.scm 60 | /src/emacsy/emacsy.tdo 61 | /src/emacsy/emacsy.tex 62 | /src/emacsy/emacsy.tex.log 63 | /src/emacsy/libemacsy.la 64 | /src/emacsy/emacsy.toc 65 | /src/emacsy/event-test.scm 66 | /src/emacsy/event.scm 67 | /src/emacsy/event.tex 68 | /src/emacsy/kbd-macro-test.scm 69 | /src/emacsy/kbd-macro.scm 70 | /src/emacsy/kbd-macro.tex 71 | /src/emacsy/keymap-test.scm 72 | /src/emacsy/keymap.scm 73 | /src/emacsy/keymap.tex 74 | /src/emacsy/klecl-test.scm 75 | /src/emacsy/klecl.scm 76 | /src/emacsy/klecl.tex 77 | /src/emacsy/minibuffer-test.scm 78 | /src/emacsy/minibuffer.scm 79 | /src/emacsy/minibuffer.tex 80 | /src/emacsy/texput.log 81 | /src/emacsy/util.scm 82 | /src/emacsy/util.tex 83 | /src/emacsy/windows.scm 84 | /src/emacsy/windows.tex 85 | /src/line-pragma.scm 86 | /src/line-pragma.tex 87 | /libtool 88 | /config.log 89 | /config.status 90 | /configure 91 | 92 | support/build-aux/compile 93 | 94 | *.log 95 | /src/emacsy/_windows.tex 96 | /src/emacsy/core.aux 97 | /src/emacsy/core.nwi 98 | /src/emacsy/emacsy.c.x 99 | /src/emacsy/help-test.scm 100 | /src/emacsy/help.scm 101 | /src/emacsy/util.aux 102 | /src/emacsy/util.nwi 103 | /src/emacsy/window-test.scm 104 | /src/emacsy/window.scm 105 | -------------------------------------------------------------------------------- /Makefile.am: -------------------------------------------------------------------------------- 1 | ACLOCAL_AMFLAGS = -I support/m4 2 | 3 | SUBDIRS = src test bin example 4 | 5 | EXTRA_DIST = README.md support bin 6 | 7 | sign-dist: dist 8 | gpg -a --output $(distdir).tar.gz.sig --detach-sig $(distdir).tar.gz 9 | 10 | verify-sig: $(distdir).tar.gz.sig $(distdir).tar.gz 11 | gpg --verify $(distdir).tar.gz.sig 12 | 13 | # I am using the following guidelines for the clean targets. 14 | # http://ftp.gnu.org/old-gnu/Manuals/automake-1.7.2/html_chapter/automake_14.html 15 | MAINTAINERCLEANFILES = Makefile.in \ 16 | libtool \ 17 | configure \ 18 | aclocal.m4 \ 19 | support/build-aux/config.guess \ 20 | support/build-aux/config.sub \ 21 | support/build-aux/depcomp \ 22 | support/build-aux/install-sh \ 23 | support/build-aux/ltmain.sh \ 24 | support/build-aux/missing \ 25 | support/build-aux/test-driver \ 26 | support/m4/libtool.m4 \ 27 | support/m4/ltoptions.m4 \ 28 | support/m4/ltsugar.m4 \ 29 | support/m4/ltversion.m4 \ 30 | support/m4/lt~obsolete.m4 \ 31 | $(distdir) \ 32 | $(distdir).tar.gz 33 | 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Emacsy 2 | ====== 3 | 4 | Emacsy is an embeddable Emacs-like library for [GNU Guile 5 | Scheme](http://www.gnu.org/software/guile/). It was a [kickstarter 6 | project](http://www.kickstarter.com/projects/568774734/emacsy-an-embeddable-emacs/?ref=kicktraq). 7 | It is now a [Google Summer of Code 2013 8 | project](https://google-melange.appspot.com/gsoc/proposal/review/google/gsoc2013/shanecelis/1). 9 | I will be working with Ludovic Courtès from the [GNU 10 | Project](http://www.gnu.org/gnu/thegnuproject.html). Keep abreast of 11 | its development by watching this repository or following me on twitter 12 | [@shanecelis](https://twitter.com/shanecelis). 13 | 14 | WARNING 15 | ------- 16 | 17 | This project is currently in development. It is as alpha as can be. 18 | Not meant for general consumption yet. Contributors, welcome. 19 | 20 | Dependencies 21 | ------------ 22 | 23 | * [GNU Guile Scheme 2.0](http://www.gnu.org/software/guile/) 24 | 25 | * [guile-lib](http://www.nongnu.org/guile-lib/) 26 | 27 | * Only necessary if building from github 28 | * [Noweb](http://www.cs.tufts.edu/~nr/noweb/) 29 | 30 | * pdflatex 31 | 32 | * automake >= v1.14 33 | 34 | If you get an error saying that "warning: macro 35 | 'AM\_EXTRA\_RECURSIVE\_TARGETS' not found in library", this means 36 | your version of automake is too old. (Alternatively, you can 37 | comment out the AM\_EXTRA\_RECURSIVE\_TARGETS in configure.ac.) 38 | 39 | * autoconf >= v2.69 40 | 41 | Building from a release (easy) 42 | ------------------------------ 43 | 44 | $ wget https://github.com/shanecelis/emacsy/releases/download/v0.1.1/emacsy-0.1.1.tar.gz 45 | $ tar xfz emacsy-0.1.1.tar.gz 46 | $ cd emacsy-0.1.1 47 | $ ./configure 48 | $ make 49 | 50 | Building from github (harder) 51 | ----------------------------- 52 | 53 | $ git clone https://github.com/shanecelis/emacsy.git 54 | $ cd emacsy/example 55 | $ git clone https://github.com/shanecelis/hello-emacsy.git 56 | $ git clone https://github.com/shanecelis/emacsy-webkit-gtk.git 57 | $ cd .. 58 | $ ./autogen.sh 59 | $ ./configure 60 | $ make 61 | 62 | 63 | Running 64 | ------- 65 | 66 | Run the [minimal example 67 | program](http://gnufoo.org/emacsy/minimal-emacsy-example.pdf) and the 68 | [barebones webkit 69 | browser](https://github.com/shanecelis/emacsy-webkit-gtk) example. 70 | 71 | $ make run 72 | 73 | ![minimal example screenshot]() 74 | 75 | 76 | 77 | 78 | 79 | Reading 80 | ------- 81 | 82 | This is a literate program, so you can read it. 83 | 84 | $ make show-doc 85 | 86 | The literate documents are bundled in the distribution as `emacys.pdf` 87 | and `hello-emacsy-paper.pdf`. 88 | 89 | Running Tests 90 | ------------- 91 | 92 | $ make check 93 | 94 | TODO 95 | ---- 96 | 97 | Lots to do. See the `todo.org` file. 98 | 99 | License 100 | ------- 101 | 102 | Emacsy is available under the GNU GPLv3+. See the bundled LICENSE file 103 | for details. 104 | -------------------------------------------------------------------------------- /autogen.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | autoreconf --force --install -I support/m4 -I/usr/local/share/aclocal 3 | -------------------------------------------------------------------------------- /bin/Makefile.am: -------------------------------------------------------------------------------- 1 | EXTRA_DIST = 2 | 3 | MAINTAINERCLEANFILES = Makefile.in warn-notangle env 4 | -------------------------------------------------------------------------------- /bin/count-lines: -------------------------------------------------------------------------------- 1 | #!/opt/local/bin/gawk -f 2 | # count-lines 3 | # 4 | # http://www.cs.tufts.edu/~nr/noweb/guide.ps 5 | BEGIN { bogus = "this is total bogosity"; 6 | codecount[bogus] = -1; docscount[bogus] = -1 7 | code = 0 8 | } 9 | /^@file / { thisfile = $2; files[thisfile] = 0 } 10 | /^@begin code/ { code = 1 } 11 | /^@begin docs/ { code = 0 } 12 | /^@nl/ { 13 | if (code == 0) 14 | docscount[thisfile]++ 15 | else 16 | codecount[thisfile]++ 17 | } 18 | END { 19 | printf " Code Docs Both File\n" 20 | for (file in files) { 21 | printf "%5d %5d %5d %s\n", 22 | codecount[file], docscount[file], 23 | codecount[file]+docscount[file], file 24 | totalcode += codecount[file] 25 | totaldocs += docscount[file] 26 | } 27 | printf "%5d %5d %5d %s\n", 28 | totalcode, totaldocs, totalcode+totaldocs, "Total" 29 | } 30 | -------------------------------------------------------------------------------- /bin/env.in: -------------------------------------------------------------------------------- 1 | #!@BASH@ 2 | # env 3 | # 4 | # Allows one to run this command in this project's local environment. 5 | 6 | ABS_TOP_SRCDIR="@abs_top_srcdir@"; 7 | 8 | if test -z "$GUILE_LOAD_PATH"; then 9 | # Must include both srcdir and builddir because of the way release builds and out of source builds work. 10 | GUILE_LOAD_PATH="@abs_top_srcdir@/src:@abs_top_builddir@/src:@abs_top_srcdir@/support/scheme"; 11 | else 12 | GUILE_LOAD_PATH="@abs_top_srcdir@/src:@abs_top_builddir@/src:@abs_top_srcdir@/support/scheme:$GUILE_LOAD_PATH"; 13 | fi 14 | 15 | if test -z "$GUILE_LOAD_COMPILED_PATH"; then 16 | GUILE_LOAD_COMPILED_PATH="@abs_top_builddir@/src"; 17 | else 18 | GUILE_LOAD_COMPILED_PATH="@abs_top_builddir@/src:$GUILE_LOAD_COMPILED_PATH"; 19 | fi 20 | 21 | if test -z "$DYLD_LIBRARY_PATH"; then 22 | DYLD_LIBRARY_PATH="@abs_top_builddir@/src/emacsy"; 23 | else 24 | DYLD_LIBRARY_PATH="@abs_top_builddir@/src/emacsy:$DYLD_LIBRARY_PATH"; 25 | fi 26 | 27 | export GUILE_LOAD_PATH GUILE_LOAD_COMPILED_PATH DYLD_LIBRARY_PATH ABS_TOP_SRCDIR; 28 | 29 | exec "$@"; 30 | -------------------------------------------------------------------------------- /bin/namespace-markup.in: -------------------------------------------------------------------------------- 1 | #!@PERL@ -w 2 | # namespace-markup.pl 3 | 4 | use strict; 5 | use Getopt::Long; 6 | 7 | my %options = (); 8 | my %namespaces = (); 9 | my $help; 10 | GetOptions ("namespace|n=s" => \%namespaces, 11 | "help" => \$help); 12 | 13 | 14 | if (@ARGV == 0 || $help) { 15 | print STDERR "usage: namespace-markup [-n basename=namespace] [-n ...] file ...\n"; 16 | print STDERR << 'END'; 17 | 18 | Creates a namespace in noweb files such that for a file named, say, 19 | 'A.nw' all references inside it like 'Function' will be re-labeled 20 | 'A:Function'. However, say I have an appendix file 'A-appendix.nw' 21 | that I want to still be in the same namespace so that when it 22 | references 'Function' it will reference 'A:Function' and not 23 | 'A-appendix:Function'. I can manually specify the namespace through 24 | the arguments of this command that the basename of the filename 25 | 'A-appendix' is actually in the 'A' namespace by using the following 26 | option -n 'A-appendix=A'. 27 | 28 | END 29 | exit(2); 30 | } 31 | my $file = 'not-defined'; 32 | $namespaces{$file} = 'not-defined'; 33 | local *INPUT; 34 | open(INPUT, "@markup@ " . join(' ', @ARGV) . " |") or die("noweb/markup failed.\n"); 35 | while (my $line = ) { 36 | if ($line =~ /^\@file ([^\.:]+)[^:]*$/) { 37 | $file = $1; 38 | if (! (defined $namespaces{$file})) { 39 | $namespaces{$file} = $file; 40 | } 41 | } 42 | if ($line =~ /^\@(defn|use) ([^+][^:]*)$/) { 43 | # I keep getting warnings here about an uninitialized value 44 | # that I can't seem to sort out. 45 | # no warnings 'uninitialized'; 46 | $line =~ s/^\@(defn|use) ([^+][^:]*)$/\@$1 $namespaces{$file}:$2/; 47 | } 48 | print $line; 49 | } 50 | 51 | -------------------------------------------------------------------------------- /bin/warn-notangle.in: -------------------------------------------------------------------------------- 1 | #!@BASH@ 2 | # warn-notangle 3 | # 4 | # Exit with an error code if there is an error in the notangle process. 5 | 6 | function usage() { 7 | echo "usage: warn-notangle [-LW] [-o output] -- " >&2; 8 | echo " -W treat warnings from notangle as errors" >&2; 9 | echo " -L add a (use-modules (line-pragma)) header to the file" >&2; 10 | exit 2; 11 | } 12 | addPrefix=0; 13 | warningsAsErrors=0; 14 | output=""; 15 | while getopts hWo:L opt; do 16 | case $opt in 17 | L) addPrefix=1;; 18 | W) warningsAsErrors=1;; 19 | h) usage;; 20 | o) output=$OPTARG;; 21 | *) echo "error: invalid option given." >&2; usage;; 22 | esac 23 | done 24 | shift $[ OPTIND - 1 ] 25 | 26 | function notangle() { 27 | if [ $addPrefix -eq 1 ]; then 28 | echo "(use-modules (line-pragma))"; 29 | fi 30 | @notangle@ "$@"; 31 | } 32 | 33 | if [ $# -eq 0 ]; then 34 | usage; 35 | fi 36 | 37 | if [ -z "$output" ]; then 38 | notangle "$@"; 39 | ec=$?; 40 | else 41 | notangle "$@" | cpif "$output"; 42 | ec=${PIPESTATUS[0]}; 43 | fi 44 | 45 | if [ $warningsAsErrors -eq 1 ] && [ $ec -ne 0 ]; then 46 | [ ! -z "$output" ] && rm "$output"; 47 | exit $ec; 48 | else 49 | exit 0; 50 | fi 51 | -------------------------------------------------------------------------------- /bin/wrapper.in: -------------------------------------------------------------------------------- 1 | #!@BASH@ 2 | # wrapper 3 | # 4 | # Wrap a given command's output with a header and footer. 5 | 6 | function usage() { 7 | echo "usage: wrapper [-H header-file] [-F footer-file] -- " >&2; 8 | exit 2; 9 | } 10 | header=""; 11 | footer=""; 12 | while getopts hH:F: opt; do 13 | case $opt in 14 | H) header=$OPTARG;; 15 | F) footer=$OPTARG;; 16 | h) usage;; 17 | *) echo "error: invalid option given." >&2; usage;; 18 | esac 19 | done 20 | shift $[ OPTIND - 1 ] 21 | 22 | if [ ! -z "$header" ]; then 23 | cat "$header"; 24 | fi 25 | "$@"; 26 | ec=$?; 27 | if [ ! -z "$footer" ]; then 28 | cat "$footer"; 29 | fi 30 | exit $ec; 31 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # -*- Autoconf -*- 2 | # Process this file with autoconf to produce a configure script. 3 | 4 | AC_PREREQ([2.63]) 5 | # We'll try to use semantic versioning. http://semver.org 6 | AC_INIT([emacsy], [0.1.2], [shane.celis@gmail.com]) 7 | AC_CONFIG_AUX_DIR([support/build-aux]) 8 | # Lies. 9 | #AM_INIT_GUILE_MODULE 10 | 11 | # We're going to use GNUMake and we're going to like it. 12 | AM_INIT_AUTOMAKE([-Wall foreign -Wno-portability parallel-tests]) 13 | AM_EXTRA_RECURSIVE_TARGETS([run show-doc]) 14 | AM_SILENT_RULES([yes]) 15 | AC_CONFIG_MACRO_DIR([support/m4]) 16 | # Checks for programs. 17 | AC_PROG_CC_C99 18 | AC_PROG_CC_C_O 19 | AC_PROG_LIBTOOL 20 | AX_CHECK_NOWEB 21 | AX_CHECK_OPEN 22 | GUILE_PROGS 23 | AC_PATH_PROG([PERL], [perl]) 24 | AC_SUBST([PERL]) 25 | 26 | AC_PATH_PROG([BASH], [bash]) 27 | AC_SUBST([BASH]) 28 | 29 | AC_PATH_PROG([guile_snarf], guile-snarf) 30 | AC_SUBST(guile_snarf) 31 | 32 | # Checks for libraries. 33 | PKG_CHECK_MODULES([GUILE], [guile-2.0]) 34 | 35 | AM_CONDITIONAL([HELLO_EMACSY], [test -f example/hello-emacsy/README.md]) 36 | 37 | AC_SUBST(DISTDIR, ["${PACKAGE_TARNAME}-${PACKAGE_VERSION}"]) 38 | 39 | #PKG_CHECK_MODULES([EMACSY], [libemacsy]) 40 | #AX_CHECK_GLUT 41 | # The autoconf macro does not prefer these frameworks over the 42 | # standard X11 locations. 43 | 44 | # Checks for header files. 45 | AC_HEADER_STDC 46 | AC_CHECK_HEADERS([stdio.h]) 47 | 48 | dnl AC_CHECK_HEADERS([tap/basic.h], [], []) 49 | 50 | # Checks for typedefs, structures, and compiler characteristics. 51 | 52 | # Checks for library functions. 53 | dnl AC_CHECK_FUNCS([puts]) 54 | 55 | # 56 | dnl AC_SUBST(EMACSY_CFLAGS, ['-I${top_srcdir}/../..']) 57 | dnl AC_SUBST(EMACSY_LIBS, ['${top_srcdir}/../../libemacsy.a']) 58 | AC_SUBST(latexdir, ['${top_srcdir}/support/latex']) 59 | AC_SUBST(imagesdir, ['${top_srcdir}/support/images']) 60 | AC_SUBST(automakedir, ['${top_srcdir}/support/automake']) 61 | AC_SUBST(helloemacsydir, ['${top_srcdir}/example/hello-emacsy/']) 62 | pdflatex="TEXINPUTS=${latexdir}:${imagesdir}:${helloemacsydir}/support/images: $pdflatex"; 63 | 64 | AC_SUBST(ENV, ['${top_builddir}/bin/env']) 65 | 66 | # Output files. 67 | AC_CONFIG_HEADERS([src/config.h]) 68 | AC_CONFIG_FILES([ Makefile 69 | bin/Makefile 70 | src/Makefile 71 | src/emacsy/Makefile 72 | test/Makefile 73 | test/works-without-noweb.sh 74 | test/print-install.sh 75 | support/pkg-config/emacsy.pc 76 | support/pkg-config/not-installed/emacsy.pc 77 | example/Makefile 78 | ], []) 79 | 80 | AC_CONFIG_FILES([bin/env], [chmod a+x bin/env]) 81 | AC_CONFIG_FILES([bin/warn-notangle], [chmod a+x bin/warn-notangle]) 82 | AC_CONFIG_FILES([bin/namespace-markup], [chmod a+x bin/namespace-markup]) 83 | AC_CONFIG_FILES([bin/wrapper], [chmod a+x bin/wrapper]) 84 | 85 | 86 | dnl We can point the example to the build directory. 87 | dnl export EMACSY_CFLAGS="-I${ac_abs_top_builddir}/src/emacsy" 88 | dnl export EMACSY_LIBS="-L${ac_abs_top_builddir}/src/emacsy/.libs" 89 | 90 | dnl Autotools are impossible to love. 91 | if test -f configure; then 92 | abs_top_srcdir="`pwd`"; 93 | abs_top_builddir="`pwd`"; 94 | elif test -f ../configure; then 95 | abs_top_srcdir="`pwd`/.."; 96 | abs_top_builddir="`pwd`"; 97 | else 98 | AC_MSG_ERROR([Can't detect src and build directories.]) 99 | fi 100 | 101 | # Unfortunately, since we build the source files using noweb, 102 | # depending on whether it is built in the source tree or out of the 103 | # sourcetree, the header files may or may not be where they ought to 104 | # be in srcdir or builddir. Bleh. 105 | export EMACSY_CFLAGS="-I${abs_top_srcdir}/src/emacsy -I${abs_top_builddir}/src/emacsy" 106 | export EMACSY_LIBS="-L${abs_top_builddir}/src/emacsy/.libs -lemacsy" 107 | export EMACSY_MODULE="${abs_top_srcdir}/src" 108 | AC_CONFIG_SUBDIRS([example/hello-emacsy]) 109 | AC_CONFIG_SUBDIRS([example/emacsy-webkit-gtk]) 110 | AC_OUTPUT 111 | -------------------------------------------------------------------------------- /example/.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | Makefile.in 3 | *.go 4 | *.defs 5 | .libs* 6 | .deps* 7 | TAGS 8 | /aclocal.m4 9 | /autom4te.cache/* 10 | /support/build-aux/config.guess 11 | /support/build-aux/config.sub 12 | /support/build-aux/depcomp 13 | /support/build-aux/install-sh 14 | /support/build-aux/ltmain.sh 15 | /support/build-aux/missing 16 | /support/build-aux/test-driver 17 | /support/m4/libtool.m4 18 | /support/m4/ltoptions.m4 19 | /support/m4/ltsugar.m4 20 | /support/m4/ltversion.m4 21 | /support/m4/lt~obsolete.m4 22 | /test/works-without-noweb.sh 23 | /src/config.h 24 | /src/config.h.in 25 | /libtool 26 | /config.log 27 | /config.status 28 | /configure 29 | -------------------------------------------------------------------------------- /example/Makefile.am: -------------------------------------------------------------------------------- 1 | SUBDIRS = . hello-emacsy emacsy-webkit-gtk 2 | 3 | MAINTAINERCLEANFILES = Makefile.in 4 | -------------------------------------------------------------------------------- /src/Makefile.am: -------------------------------------------------------------------------------- 1 | SUBDIRS = emacsy 2 | 3 | MAINTAINERCLEANFILES = Makefile.in config.h.in 4 | 5 | NOWEB_FILES = line-pragma.nw 6 | 7 | NOWEB_PRODUCTS = line-pragma.scm 8 | CLEANFILES = $(NOWEB_CLEANFILES) 9 | BUILT_SOURCES = $(NOWEB_BUILT_FILES) 10 | EXTRA_DIST = convenience-lambda.scm cursor-list.scm $(NOWEB_EXTRA_DIST) 11 | 12 | guilemoduledir = $(prefix)/share/guile/site/ 13 | dist_guilemodule_DATA = line-pragma.scm convenience-lambda.scm cursor-list.scm 14 | 15 | include $(top_srcdir)/support/automake/noweb.am 16 | -------------------------------------------------------------------------------- /src/convenience-lambda.scm: -------------------------------------------------------------------------------- 1 | ;; convenience-lambda.scm 2 | ;; 3 | ;; This syntax was inspired by arc and Clojure's anonymous procedure 4 | ;; syntax. 5 | ;; 6 | ;; #.\ (+ %1 %2) -> (lambda (%1 %2) (+ %1 %2)) 7 | ;; #.\ (+ % %%) -> (lambda (% %%) (+ % %%)) 8 | ;; 9 | ;; The .\ is supposed to approximate the lowercase lambda character in 10 | ;; ascii. 11 | ;; 12 | ;; Shane Celis 13 | 14 | (define-module (convenience-lambda) 15 | #:use-module (ice-9 regex)) 16 | 17 | (eval-when (compile load eval) 18 | (define (convenience-lambda char port) 19 | (let ((uses-numbers? 'unknown)) 20 | (define (range a b) 21 | (if (> a b) 22 | '() 23 | (cons a (range (1+ a) b)))) 24 | (define (scan-tree lst) 25 | "scan-tree :: tree -> number" 26 | (cond 27 | ((symbol? lst) 28 | (let ((str (symbol->string lst))) 29 | (if (char=? #\% (string-ref str 0)) 30 | (if (string-match "^%[0-9]+" str) 31 | (if uses-numbers? 32 | (begin 33 | (set! uses-numbers? #t) 34 | (string->number (string-trim str #\%))) 35 | (error "Pick a convention. Use %, %% or %1, %2 not both.")) 36 | (if (string-match "^%+" str) 37 | (if (or (eq? uses-numbers? 'unknown) 38 | (eq? uses-numbers? #f)) 39 | (begin 40 | (set! uses-numbers? #f) 41 | (string-length str)) 42 | (error "Pick a convention. Use %, %% or %1, %2 not both.") 43 | ) 44 | (error "Expected %1 or % to name positional variables; found '~a' instead." str))) 45 | 0))) 46 | ((pair? lst) 47 | (max (scan-tree (car lst)) (scan-tree (cdr lst)))) 48 | (else 0))) 49 | (if (char=? #\\ (read-char port)) 50 | (let* ((content (read port)) 51 | (arg-count (scan-tree content))) 52 | (display (number->string arg-count)) 53 | `(lambda ,(map (lambda (x) 54 | (string->symbol 55 | (if uses-numbers? 56 | (string-concatenate (list "%" (number->string x))) 57 | (make-string x #\%)))) 58 | (range 1 arg-count)) 59 | ,content)) 60 | (error "Expected form like #.\\ (+ %1 %2)")))) 61 | 62 | (read-hash-extend #\. convenience-lambda)) 63 | -------------------------------------------------------------------------------- /src/cursor-list.scm: -------------------------------------------------------------------------------- 1 | #| 2 | cursor-list.scm 3 | 4 | This module creates a list with a cursor, that is, a position 5 | within the list. It's represented by two lists. The "left" list is 6 | held in reverse order which has the preceding contents. The "right" 7 | list is held in the conventional order. 8 | 9 | |# 10 | 11 | (define-module (cursor-list) 12 | #:use-module (ice-9 optargs) 13 | #:use-module (srfi srfi-1) 14 | #:use-module (srfi srfi-9) 15 | #:use-module (srfi srfi-9 gnu) 16 | #:export (make-cursor-list 17 | cursor-right? 18 | cursor-right! 19 | cursor-left? 20 | cursor-left! 21 | cursor-right-insert! 22 | cursor-left-insert! 23 | cursor-right-delete! 24 | cursor-left-delete! 25 | cursor-right-ref 26 | cursor-right-set! 27 | cursor-left-ref 28 | cursor-left-set! 29 | cursor-list? 30 | cursor-list->list)) 31 | 32 | (define-record-type 33 | (%make-cursor-list left right) 34 | cursor-list? 35 | (left left set-left!) 36 | (right right set-right!)) 37 | 38 | (define* (make-cursor-list list #:optional (index 0)) 39 | (%make-cursor-list (reverse (take list index)) (drop list index))) 40 | 41 | (define (cursor-right-ref clist) 42 | (car (right clist))) 43 | 44 | (define (cursor-left-ref clist) 45 | (car (left clist))) 46 | 47 | (define (cursor-right-set! clist item) 48 | (set-car! (right clist) item) 49 | *unspecified*) 50 | 51 | (define (cursor-left-set! clist item) 52 | (set-car! (left clist) item) 53 | *unspecified*) 54 | 55 | (define* (cursor-right? clist #:optional (count 1)) 56 | (>= (length (right clist)) count)) 57 | 58 | (define* (cursor-left? clist #:optional (count 1)) 59 | (>= (length (left clist)) count)) 60 | 61 | (define (cursor-right! clist) 62 | (when (cursor-right? clist) 63 | (set-left! clist (cons (cursor-right-ref clist) (left clist))) 64 | (set-right! clist (cdr (right clist)))) 65 | *unspecified*) 66 | 67 | (define (cursor-left! clist) 68 | (when (cursor-left? clist) 69 | (set-right! clist (cons (cursor-left-ref clist) (right clist))) 70 | (set-left! clist (cdr (left clist)))) 71 | *unspecified*) 72 | 73 | (define (cursor-right-insert! clist item) 74 | (set-right! clist (cons item (right clist))) 75 | *unspecified*) 76 | 77 | (define (cursor-left-insert! clist item) 78 | (set-left! clist (cons item (left clist))) 79 | *unspecified*) 80 | 81 | (define (cursor-right-delete! clist) 82 | (set-right! clist (cdr (right clist))) 83 | *unspecified*) 84 | 85 | (define (cursor-left-delete! clist) 86 | (set-left! clist (cdr (left clist))) 87 | *unspecified*) 88 | 89 | (define (cursor-list->list clist) 90 | (append (reverse (left clist)) (right clist))) 91 | 92 | (set-record-type-printer! 93 | (lambda (clist port) 94 | (format port "#" 95 | (reverse (left clist)) 96 | (right clist)))) 97 | -------------------------------------------------------------------------------- /src/emacsy/Makefile.am: -------------------------------------------------------------------------------- 1 | 2 | # Stop make from deleting intermediate files. 3 | # http://darrendev.blogspot.com/2008/06/stopping-make-delete-intermediate-files.html 4 | .SECONDARY: 5 | 6 | NOWEB_DOCS = _emacsy.pdf 7 | # Any noweb document can be built by itself as a stand-alone document by 8 | # appending a -paper suffix to its name. So if you're working on just 9 | # the command.nw, you may want to change NOWEB_DOCS to only make its 10 | # PDF. 11 | # 12 | #NOWEB_DOCS = command-paper.pdf 13 | 14 | NOWEAVE_HEADER = $(top_srcdir)/support/noweb/paper-header.nw 15 | NOWEAVE_FOOTER = $(top_srcdir)/support/noweb/paper-footer.nw 16 | 17 | PARTIAL_TEX = _emacsy-c-api.tex _event.tex _keymap.tex _command.tex _block.tex _klecl.tex _advice.tex _buffer.tex _minibuffer.tex _core.tex _window.tex _util.tex 18 | _emacsy.pdf : $(PARTIAL_TEX) 19 | 20 | # XXX this rule that pulls something from one of the examples is not working. 21 | # I'm going to just copy the file over for the meantime. Ugh. 22 | 23 | # hello-emacsy.tex : $(helloemacsydir)/src/hello-emacsy.nw 24 | # $(MAKE) -C $(helloemacsydir) all 25 | # cp $(helloemacsydir)/src/hello-emacsy.tex hello-emacsy.tex 26 | 27 | EXTRA_DIST = $(SCHEME_TESTS) $(NOWEB_FILES) 28 | 29 | NOWEB_FILES = emacsy.nw emacsy-c-api.nw event.nw util.nw keymap.nw \ 30 | command.nw buffer.nw block.nw klecl.nw kbd-macro.nw \ 31 | minibuffer.nw core.nw advice.nw window.nw help.nw self-doc.nw mru-stack.nw 32 | 33 | NOWEB_SCHEME_TESTS = event-test.scm self-doc-test.scm keymap-test.scm \ 34 | command-test.scm buffer-test.scm block-test.scm klecl-test.scm \ 35 | kbd-macro-test.scm core-test.scm emacsy-test.scm advice-test.scm \ 36 | minibuffer-test.scm window-test.scm help-test.scm mru-stack-test.scm 37 | 38 | NOWEB_SCHEME_FILES = event.scm util.scm self-doc.scm keymap.scm \ 39 | command.scm buffer.scm block.scm klecl.scm kbd-macro.scm \ 40 | minibuffer.scm core.scm emacsy.scm advice.scm window.scm help.scm mru-stack.scm 41 | 42 | SCHEME_FILES = $(NOWEB_SCHEME_FILES) coroutine.scm agenda.scm mode.scm job.scm 43 | 44 | SCHEME_TESTS = $(NOWEB_SCHEME_TESTS) job-test.scm 45 | 46 | GOBJECTS = $(SCHEME_FILES:%.scm=%.go) 47 | 48 | NOWEB_PRODUCTS = $(NOWEB_SCHEME_FILES) $(NOWEB_SCHEME_TESTS) emacsy.h emacsy.c 49 | 50 | NOWEB_INCLUDES = $(top_srcdir)/support/noweb/boiler-plate.nw 51 | 52 | BUILT_SOURCES = $(NOWEB_PRODUCTS) 53 | 54 | CLEANFILES = $(NOWEB_CLEANFILES) $(GOBJECTS) 55 | 56 | distdir-local: 57 | $(MAKE) all 58 | 59 | doc: $(NOWEB_DOCS) 60 | 61 | # The util file may have its chunks specified anywhere. 62 | util.scm : util.nw $(NOWEB_FILES) 63 | 64 | if LINE_PRAGMA 65 | LINE_PRAGMA_FLAGS = -L 66 | else 67 | LINE_PRAGMA_FLAGS = 68 | endif 69 | 70 | MARKUP_FLAGS = -markup "$(top_builddir)/bin/namespace-markup --" 71 | #WARN_NOTANGLE_FLAGS = -W # treat warnings as errors 72 | WARN_NOTANGLE_C_FLAGS = 73 | WARN_NOTANGLE_LISP_FLAGS = $(LINE_PRAGMA_FLAGS) # add a (use-modules (line-pragma)) header 74 | NOWEAVE_FLAGS = $(MARKUP_FLAGS) 75 | NOTANGLE_C_FLAGS = -c $(LINE_PRAGMA_FLAGS) $(MARKUP_FLAGS) 76 | NOTANGLE_LISP_FLAGS = $(LINE_PRAGMA_FLAGS) $(MARKUP_FLAGS) 77 | NOTANGLE_H_FLAGS = $(LINE_PRAGMA_FLAGS) $(MARKUP_FLAGS) 78 | lib_LTLIBRARIES = libemacsy.la 79 | 80 | AM_CFLAGS = $(GUILE_CFLAGS) 81 | libemacsy_la_LIBADD = $(GUILE_LIBS) 82 | libemacsy_la_SOURCES = emacsy.c 83 | include_HEADERS = emacsy.h 84 | 85 | DISTCLEANFILES = $(PARTIAL_TEX) _emacsy.tex 86 | MAINTAINERCLEANFILES = Makefile.in config.h.in 87 | 88 | guilemoduledir = $(prefix)/share/guile/site/$(PACKAGE_TARNAME) 89 | dist_guilemodule_DATA = $(SCHEME_FILES) $(GOBJECTS) 90 | 91 | AM_ETAGSFLAGS = -l scheme 92 | ETAGS_ARGS = $(SCHEME_FILES) $(SCHEME_TESTS) 93 | TAGS_DEPENDENCIES = $(SCHEME_FILES) $(SCHEME_TESTS) 94 | 95 | #TESTS_ENVIRONMENT = LOG_COMPILER 96 | TESTS = $(SCHEME_TESTS) 97 | TEST_EXTENSIONS = .scm 98 | SCM_LOG_COMPILER = $(top_builddir)/bin/env $(GUILE) 99 | 100 | include $(top_srcdir)/support/automake/noweb.am 101 | include $(top_srcdir)/support/automake/guile.am 102 | 103 | emacsy.h emacsy.c : emacsy-c-api.nw 104 | 105 | dist-hook: _emacsy.pdf 106 | cp $(builddir)/_emacsy.pdf $(top_distdir)/emacsy.pdf 107 | 108 | 109 | -------------------------------------------------------------------------------- /src/emacsy/advice.nw: -------------------------------------------------------------------------------- 1 | \section{Advice} 2 | 3 | %\epigraph{Wise men don't need advice. Fools won't take it.}{Benjamin Franklin} 4 | 5 | %\epigraph{Nobody can give you wiser advice than yourself.}{Marcus Tullius Cicero} 6 | 7 | \epigraph{No enemy is worse than bad advice.}{Sophocles} 8 | 9 | 10 | Emacs has a facility to define ``advice'' these are pieces of code 11 | that run before, after, or around an already defined function. This 12 | \href{http://electricimage.net/cupboard/2013/05/04/on-defadvice/}{article} 13 | provides a good example. 14 | 15 | <>= 16 | (define-module (emacsy advice) 17 | #:use-module (srfi srfi-9) 18 | ) 19 | 20 | <> 21 | 22 | <> 23 | 24 | <> 25 | @ 26 | 27 | How will this work? Before we try to make the macro, let's focus on 28 | building up the functions. We want to have a function that we can 29 | substitute for the original function which will have a number of 30 | before, after, and around pieces of advice that can be attached to it. 31 | 32 | <>= 33 | (define-record-type 34 | (make-record-of-advice original before around after) 35 | record-of-advice? 36 | (original advice-original) 37 | (before advice-before set-advice-before!) 38 | (around advice-around set-advice-around!) 39 | (after advice-after set-advice-after!)) 40 | @ 41 | 42 | <>= 43 | (define-record-type 44 | (make-piece-of-advice procedure name class priority flag) 45 | piece-of-advice? 46 | (procedure poa-procedure) 47 | (name poa-name) ;; symbol not string 48 | (class poa-class set-poa-class!) 49 | (priority poa-priority set-poa-priority!) 50 | (flag poa-flag set-poa-flag!)) 51 | @ 52 | 53 | <>= 54 | (define (make-advising-function advice) 55 | (lambda args 56 | (let ((around-advices (append (advice-around advice) 57 | (list (make-piece-of-advice 58 | (advice-original 59 | advice) 60 | 'original 61 | 'bottom 62 | 0 63 | 'activate)))) 64 | (result #f)) 65 | (define (my-next-advice) 66 | (if (null? around-advices) 67 | (throw 'next-advices-drained) 68 | (let ((next-one-around (car around-advices))) 69 | (set! around-advices (cdr around-advices)) 70 | (apply (poa-procedure next-one-around) args)))) 71 | ;; This could be done more cleanly. For instance, 72 | ;; If one calls (next-advice) more than once, 73 | ;; they drain all the advice rather than calling 74 | ;; the same advice again, which is probably 75 | ;; the more correct behavior. 76 | 77 | (for-each (lambda (before) 78 | (apply (poa-procedure before) args)) 79 | (advice-before advice)) 80 | 81 | (set! result (with-fluid* next-advice-func my-next-advice 82 | (lambda () 83 | (next-advice)))) 84 | (for-each (lambda (after) 85 | (apply (poa-procedure after) result args)) 86 | (advice-after advice)) 87 | result))) 88 | @ 89 | 90 | <>= 91 | (define (next-advice) 92 | (if (fluid-bound? next-advice-func) 93 | ((fluid-ref next-advice-func)) 94 | (throw 'no-next-advice-bound))) 95 | @ 96 | 97 | <>= 98 | (define next-advice-func (make-fluid)) 99 | @ 100 | 101 | To test this functionality, we're going to make some counter 102 | procedures. 103 | 104 | <>= 105 | (define (my-orig-func x) 106 | (+ x 1)) 107 | 108 | (define (make-counter) 109 | (let ((x 0)) 110 | (lambda args 111 | (if (and (= (length args) 1) (eq? (car args) 'count)) 112 | x 113 | (begin (set! x (+ x 1)) 114 | (car args)))))) 115 | 116 | (define a-before (make-counter)) 117 | @ 118 | 119 | Let's make an identity advice procedure. It does nothing, but it does 120 | wrap around the function. 121 | <>= 122 | (define advice (make-record-of-advice my-orig-func '() '() '())) 123 | 124 | (define advised-func (make-advising-function advice)) 125 | (check (a-before 'count) => 0) 126 | (check (my-orig-func 1) => 2) 127 | (check (advised-func 1) => 2) 128 | (check (a-before 'count) => 0) 129 | @ 130 | 131 | Let's test this with the simple functionality of having a piece of 132 | before advice. 133 | 134 | <>= 135 | (define advice (make-record-of-advice my-orig-func (list (make-piece-of-advice a-before 'a-before 'before 0 'activate)) '() '())) 136 | 137 | (define advised-func (make-advising-function advice)) 138 | (check (a-before 'count) => 0) 139 | (check (my-orig-func 1) => 2) 140 | (check (advised-func 1) => 2) 141 | (check (a-before 'count) => 1) 142 | @ 143 | 144 | Let's check the after advice. 145 | <>= 146 | (define a-after (make-counter)) 147 | (define advice (make-record-of-advice my-orig-func '() '() 148 | (list (make-piece-of-advice a-after 'a-after 'after 0 'activate)))) 149 | 150 | (define advised-func (make-advising-function advice)) 151 | (check (a-after 'count) => 0) 152 | (check (my-orig-func 1) => 2) 153 | (check (advised-func 1) => 2) 154 | (check (a-after 'count) => 1) 155 | @ 156 | 157 | Let's check the after advice. 158 | <>= 159 | (define a-around (lambda args 160 | (next-advice) 161 | 1)) 162 | (define advice (make-record-of-advice my-orig-func '() (list (make-piece-of-advice a-around 'a-around 'around 0 'activate)) '())) 163 | 164 | (define advised-func (make-advising-function advice)) 165 | (check (my-orig-func 1) => 2) 166 | (check (advised-func 1) => 1) 167 | @ 168 | 169 | So the rudimentary elements of our advice facility works. Now, we 170 | want to make it so that we can alter the advice of an existing 171 | function. We'll add a property to the procedure, such that we can 172 | tell if it is an ``advised'' procedure. 173 | 174 | <>= 175 | (define (advised? proc) 176 | (and (procedure? proc) 177 | (assq 'record-of-advice 178 | (procedure-properties proc)) 179 | #t)) 180 | @ 181 | 182 | <>= 183 | (define (make-advising-function* proc record-of-advice) 184 | (let ((advised-proc (make-advising-function proc record-of-advice))) 185 | (set-procedure-property! proc 'record-of-advice record-of-advice))) 186 | @ 187 | 188 | <>= 189 | (define (remove-advice! procedure name) 190 | (if (advised? procedure) 191 | (let ((roa (procedure-property procedure 'record-of-advice))) 192 | (for-each (lambda (class) 193 | (match (getter-and-setter-for-poa class) 194 | ((getter setter!) 195 | 196 | (setter! (delete! name (getter roa) (lambda (name elem) 197 | (eq? (poa-name elem)))))))) 198 | '(before around after))))) 199 | @ 200 | 201 | <>= 202 | (define (getter-and-setter-for-poa poa-class) 203 | (cond ((eq? poa-class 'before) 204 | (cons advice-before set-advice-before!) 205 | (eq? poa-class 'around) 206 | (cons advice-around set-advice-around!) 207 | (eq? poa-class 'after) 208 | (cons advice-after set-advice-after!) 209 | (else 210 | (throw 'invalid-advice-class))))) 211 | @ 212 | 213 | <>= 214 | (define (add-advice! procedure piece-of-advice) 215 | "Add a piece-of-advice to the procedure. Returns the advised 216 | procedure." 217 | (define (sort-by! lst f) 218 | (sort! lst (lambda (a b) 219 | (< (f a) (f b))))) 220 | (if (not (advised? procedure)) 221 | ;; Procedure has never been advised. 222 | (add-advice (make-advising-function* procedure (make-record-of-advice procedure '() '() '())) piece-of-advice) 223 | ;; Add a new piece of advice. 224 | (begin 225 | (remove-advice! procedure (poa-name piece-of-advice)) 226 | (let ((roa (procedure-property procedure 'record-of-advice))) 227 | (match (getter-setter-for-poa (poa-class piece-of-advice)) 228 | ((getter setter!) 229 | (setter! 230 | roa 231 | (sort-by! (cons piece-of-advice (getter roa)) 232 | poa-priority))))) 233 | procedure))) 234 | @ 235 | 236 | <>= 237 | (use-modules (emacsy advice) 238 | (emacsy event) 239 | (emacsy klecl) 240 | (oop goops) 241 | (srfi srfi-11)) 242 | 243 | (eval-when (compile load eval) 244 | ;; Some trickery so we can test private procedures. 245 | (module-use! (current-module) (resolve-module '(emacsy advice)))) 246 | 247 | <<+ Test Preamble>> 248 | <> 249 | <<+ Test Postscript>> 250 | @ 251 | -------------------------------------------------------------------------------- /src/emacsy/agenda.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Deferred procedure scheduling. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (emacsy agenda) 25 | #:use-module (ice-9 q) 26 | #:use-module (srfi srfi-1) 27 | #:use-module (srfi srfi-9) 28 | #:use-module (emacsy coroutine) 29 | #:export (make-agenda 30 | with-agenda 31 | agenda-schedule 32 | agenda-schedule-interval 33 | update-agenda 34 | clear-agenda 35 | wait)) 36 | 37 | ;; This code is a modified version of the agenda implementation in 38 | ;; SICP. Thank you, SICP! 39 | 40 | ;;; 41 | ;;; Time segment 42 | ;;; 43 | 44 | (define-record-type 45 | (%make-time-segment time queue) 46 | time-segment? 47 | (time segment-time) 48 | (queue segment-queue)) 49 | 50 | (define (make-time-segment time . callbacks) 51 | "Create a new time segment at TIME and enqueus everything in the 52 | list CALLBACKS." 53 | (let ((segment (%make-time-segment time (make-q)))) 54 | ;; Enqueue all callbacks 55 | (for-each (lambda (c) (segment-enq segment c)) callbacks) 56 | segment)) 57 | 58 | (define (segment-enq segment callback) 59 | "Add the CALLBACK procedure to SEGMENT's queue." 60 | (enq! (segment-queue segment) callback)) 61 | 62 | ;;; 63 | ;;; Agenda 64 | ;;; 65 | 66 | (define-record-type 67 | (%make-agenda time segments) 68 | agenda? 69 | (time agenda-time set-agenda-time!) 70 | (segments agenda-segments set-agenda-segments!)) 71 | 72 | (define (make-agenda) 73 | "Create a new, empty agenda." 74 | (%make-agenda 0 '())) 75 | 76 | ;; The global agenda that will be used when schedule is called outside 77 | ;; of a with-agenda form. 78 | (define global-agenda (make-agenda)) 79 | 80 | (define *current-agenda* global-agenda) 81 | 82 | ;; emacs: (put 'with-agenda 'scheme-indent-function 1) 83 | (define-syntax-rule (with-agenda agenda body ...) 84 | (begin 85 | (set! *current-agenda* agenda) 86 | body 87 | ... 88 | (set! *current-agenda* global-agenda))) 89 | 90 | (define (agenda-empty? agenda) 91 | "Return #t if AGENDA has no scheduled procedures." 92 | (null? (agenda-segments agenda))) 93 | 94 | (define (first-segment agenda) 95 | "Return the first time segment in AGENDA." 96 | (car (agenda-segments agenda))) 97 | 98 | (define (rest-segments agenda) 99 | "Return everything but the first segment in AGENDA." 100 | (cdr (agenda-segments agenda))) 101 | 102 | (define (agenda-add-segment agenda time callback) 103 | "Add a new time segment to the beginning of AGENDA at the given TIME 104 | and enqueue CALLBACK." 105 | (set-agenda-segments! agenda 106 | (cons (make-time-segment time callback) 107 | (agenda-segments agenda)))) 108 | 109 | (define (insert-segment segments time callback) 110 | "Insert a new time segment after the first segment in SEGMENTS." 111 | (set-cdr! segments 112 | (cons (make-time-segment time callback) 113 | (cdr segments)))) 114 | 115 | (define (first-agenda-item agenda) 116 | "Return the first time segment queue in AGENDA." 117 | (if (agenda-empty? agenda) 118 | (error "Agenda is empty") 119 | (segment-queue (first-segment agenda)))) 120 | 121 | (define (agenda-time-delay agenda dt) 122 | "Return the sum of the time delta, DT, and the current time of AGENDA." 123 | (+ (agenda-time agenda) (inexact->exact (round dt)))) 124 | 125 | (define (%agenda-schedule agenda callback dt) 126 | "Schedule the procedure CALLBACK in AGENDA to be run DT updates from now." 127 | (let ((time (agenda-time-delay agenda dt))) 128 | (define (belongs-before? segments) 129 | (or (null? segments) 130 | (< time (segment-time (car segments))))) 131 | 132 | (define (add-to-segments segments) 133 | ;; Add to existing time segment if the times match 134 | (if (= (segment-time (car segments)) time) 135 | (segment-enq (car segments) callback) 136 | ;; Continue searching 137 | (if (belongs-before? (cdr segments)) 138 | ;; Create new time segment and insert it where it belongs 139 | (insert-segment segments time callback) 140 | ;; Continue searching 141 | (add-to-segments (cdr segments))))) 142 | 143 | ;; Handle the case of inserting a new time segment at the 144 | ;; beginning of the segment list. 145 | (if (belongs-before? (agenda-segments agenda)) 146 | ;; Add segment if it belongs at the beginning of the list... 147 | (agenda-add-segment agenda time callback) 148 | ;; ... Otherwise, search for the right place 149 | (add-to-segments (agenda-segments agenda))) 150 | *unspecified*)) 151 | 152 | (define (flush-queue! q) 153 | "Dequeue and execute every member of Q." 154 | (unless (q-empty? q) 155 | ((deq! q)) ;; Execute scheduled procedure 156 | (flush-queue! q))) 157 | 158 | (define (%update-agenda agenda) 159 | "Move AGENDA forward in time and run scheduled procedures." 160 | (set-agenda-time! agenda (1+ (agenda-time agenda))) 161 | (let next-segment () 162 | (unless (agenda-empty? agenda) 163 | (let ((segment (first-segment agenda))) 164 | ;; Process time segment if it is scheduled before or at the 165 | ;; current agenda time. 166 | (when (>= (agenda-time agenda) (segment-time segment)) 167 | (flush-queue! (segment-queue segment)) 168 | (set-agenda-segments! agenda (rest-segments agenda)) 169 | (next-segment)))))) 170 | 171 | (define (%clear-agenda agenda) 172 | "Remove all scheduled procedures from AGENDA." 173 | (set-agenda-segments! agenda '())) 174 | 175 | (define* (agenda-schedule thunk #:optional (delay 1)) 176 | "Schedule THUNK in the current agenda to run after DELAY updates (1 177 | by default)." 178 | (%agenda-schedule *current-agenda* thunk delay)) 179 | 180 | (define* (agenda-schedule-interval thunk #:optional (interval 1) (delay 1)) 181 | "Schedule THUNK in the current agenda to run after DELAY updates and 182 | run every INTERVAL updates thereafter. Both DELAY and INTERVAL default 183 | to 1. Simply pass THUNK and nothing else to schedule THUNK to be run 184 | upon every update." 185 | (%agenda-schedule *current-agenda* 186 | (lambda () 187 | (thunk) 188 | (agenda-schedule-interval thunk interval interval)) 189 | delay)) 190 | 191 | (define (update-agenda) 192 | "Update the current agenda." 193 | (%update-agenda *current-agenda*)) 194 | 195 | (define (clear-agenda) 196 | "Clear the current agenda." 197 | (%clear-agenda *current-agenda*)) 198 | 199 | (define* (wait #:optional (delay 1)) 200 | "Yield coroutine and schdule the continuation to be run after DELAY 201 | ticks." 202 | (yield (lambda (resume) (agenda-schedule resume delay)))) 203 | -------------------------------------------------------------------------------- /src/emacsy/block.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | \section{Block Module} 3 | 4 | \epigraph{Wearied I fell asleep: But now lead on; In me is no delay; with thee to go, Is to stay here}{Paradise Lost \\John Milton} 5 | 6 | The [[block]] module handles blocking in Emacsy. When I prototyped 7 | Emacsy, I considered this the riskiest part of the project. If I 8 | couldn't get this to work, it wouldn't be worth trying to develop the 9 | idea further. To understand what I mean, one can try running the 10 | following in Emacs \verb|M-: (read-key)|. This will evaluate 11 | [[read-key]] and effectively block until there is another key press. 12 | 13 | Implementing ``blocking'' on a small set of bare functions can be done 14 | without too much trickery. However, what if you have computations 15 | that follow after these functions? For instance if you evaluate 16 | \verb|M-: (message "Got %s" (read-key))|, [[read-key]] must block 17 | until a key is pressed, then resume the computation that will call 18 | [[message]]. An Operating System must perform a similar operation 19 | whenever a system call is made, usually implemented using interrupts 20 | or traps. Without recourse to interrupts and bare stack manipulation, 21 | what can we do to achieve a similar feature? 22 | 23 | GNU Guile has a terrific feature called delimited continuations. Here 24 | is an example of a delimited continuation from the Guile Manual. This 25 | continuation [[cont]] 26 | 27 | \begin{verbatim} 28 | (define cont 29 | (call-with-prompt 30 | ;; tag 31 | 'foo 32 | ;; thunk 33 | (lambda () 34 | (+ 34 (abort-to-prompt 'foo))) 35 | ;; handler 36 | (lambda (k) k))) 37 | \end{verbatim} 38 | 39 | \noindent could be rewritten as 40 | 41 | \begin{verbatim} 42 | (define cont 43 | (lambda (x) 44 | (+ 34 x))) 45 | \end{verbatim}. 46 | 47 | \noindent I had to read and re-read this example to let it sink in. 48 | What does it buy us? It allows us to abort a computation at any time 49 | and resume it later.\footnote{Lua's coroutines also seem like a good 50 | candidate for pulling off a trick like this. Python's generators, 51 | however, do not.} So if we were to implement [[read-key]], we abort 52 | the computation if there has been no key press. Our main loop in 53 | \verb|C| continues to run, redraw, wait for key presses. When a key 54 | press comes, we can resume that computation---that continuation. 55 | That's the idea. What's beautiful about this is that the user code 56 | has access to the same rich input services as the system code without 57 | any unnatural contortions. These ``system calls'' look like regular 58 | procedure calls much like the Unix call to [[open]] looks like a 59 | regular function call. 60 | 61 | One of the key features I figured one bought by embedding a 62 | higher-level language like Scheme was garbage collection. High-level 63 | blocking while still being low-level non-blocking is a huge boon. 64 | What we'll implement is a simple blocking system using Guile's 65 | delimited continuations, also called prompts. 66 | 67 | Let's start with the tests, so the usage is somewhat obvious. 68 | 69 | <>= 70 | (define done-blocking? #f) 71 | (define (i-block) 72 | (block-yield) 73 | (set! done-blocking? #t)) 74 | @ 75 | 76 | [[i-block]] will immediately yield. If it is not called with 77 | [[call-blockable]] then it will throw an error. 78 | 79 | <>= 80 | (check-throw (i-block) => 'misc-error) 81 | @ 82 | 83 | <>= 84 | (define-public (block-yield) 85 | ;; I forgot why I'm running this thunk. 86 | (run-thunk (abort-to-prompt 'block 'block-until 87 | (const #t) #t))) 88 | @ 89 | 90 | [[call-blockable]] will handle any aborts to the [['block]] prompt. 91 | If the thunk aborts, it adds an instance of the class 92 | [[]] to a list of such instances. 93 | 94 | <>= 95 | (define blocking-continuations '()) 96 | @ 97 | 98 | <>= 99 | (define-public (call-blockable thunk) 100 | (let ((bc #f)) 101 | (call-with-prompt 102 | 'block 103 | thunk 104 | (lambda (cc kind . args) 105 | (case kind 106 | ((block-until) 107 | (let ((continue-command-loop? #t) 108 | (continue-wait? #t)) 109 | (set! bc <>) 110 | ;; Remember this bc. 111 | (cons! bc blocking-continuations)))))) 112 | bc)) 113 | @ 114 | 115 | <>= 116 | ;; I want to get rid of this state if I can. 117 | (define-public continue-command-loop? (make-unbound-fluid)) 118 | @ 119 | 120 | Let's add a little syntactic sugar [[with-blockable]]. 121 | 122 | <>= 123 | (define-syntax-public with-blockable 124 | (syntax-rules () 125 | ((with-blockable e ...) 126 | (call-blockable (lambda () e ...))))) 127 | @ 128 | 129 | <>= 130 | (make 131 | #:tag 'block-until 132 | #:continuation cc 133 | #:loop-number 0 134 | #:continue-when? (car args) 135 | #:continue-now 136 | (lambda () 137 | (set! continue-command-loop? #f) 138 | (if continue-wait? 139 | (call-blockable 140 | (lambda () (cc (lambda () #t)))))) 141 | #:serial? (cadr args)) 142 | @ 143 | 144 | Now we can call [[i-block]] and capture its continuation. 145 | 146 | <>= 147 | (check-true (call-blockable (lambda () (i-block)))) 148 | (check (length blocking-continuations) => 1) 149 | @ 150 | 151 | To possibly resume these continuations, we're going to call 152 | [[block-tick]]. Additionally, continuations come in two flavors: 153 | serial and non-serial. The constraints on resuming are different. A 154 | non-serial block can be resumed whenever the 155 | [[continue-when?]]\todo{rename continue-now?} thunk return true. A 156 | serial block, however, will only be resumed after every other serial 157 | block that has a greater number, meaning more recent, has been 158 | resumed. 159 | 160 | <>= 161 | (define-public (block-tick) 162 | (set! blocking-continuations 163 | ;; Sort the continuations by the most recent ones. 164 | (sort! blocking-continuations (lambda (a b) 165 | (> (number a) (number b))))) 166 | (let ((ran-serial? #f)) 167 | (for-each 168 | (lambda (bc) 169 | (if (not (serial? bc)) 170 | ;; If it's not serial, we might run it. 171 | (maybe-continue bc) 172 | ;; If it's serial, we only run the top one. 173 | (if (and (not ran-serial?) (serial? bc)) 174 | (begin 175 | (if (maybe-continue bc) 176 | (set! ran-serial? #t)))))) 177 | blocking-continuations)) 178 | ;; Keep everything that hasn't been run. 179 | (set! blocking-continuations 180 | (filter! (lambda (bc) (not (ran? bc))) 181 | blocking-continuations)) 182 | ;(format #t "blocking-continuations #~a of ~a~%" (length blocking-continuations) (map number blocking-continuations)) 183 | (when (or (null? blocking-continuations) 184 | (null? (filter serial? blocking-continuations))) 185 | (run-hook no-blocking-continuations-hook)) 186 | #t) 187 | @ 188 | 189 | \todo[inline]{Maybe get rid of no-blocking-continuations-hook and just have a 190 | predicate to test for whether any blocks exist?} 191 | 192 | <>= 193 | (define*-public (blocking?) 194 | (> (length blocking-continuations) 0)) 195 | @ 196 | 197 | <>= 198 | (define-method (maybe-continue (obj )) 199 | (if (and (not (ran? obj)) 200 | ; (or run-serial? (serial? obj)) 201 | ;; this line crashed. 202 | (run-thunk (slot-ref obj 'continue-when?))) 203 | (begin (set! (ran? obj) #t) 204 | (run-thunk (slot-ref obj 'continue-now)) 205 | #t) 206 | #f)) 207 | @ 208 | 209 | If there are no blocking continuations, we run this hook. 210 | 211 | <>= 212 | (define-public no-blocking-continuations-hook (make-hook)) 213 | @ 214 | 215 | Now we should be able to resume [[i-block]] by running [[block-tick]]. 216 | 217 | <>= 218 | (check done-blocking? => #f) 219 | (check (block-tick) => #t) 220 | (check done-blocking? => #t) 221 | (check (length blocking-continuations) => 0) 222 | @ 223 | 224 | In addition to simply yielding we can block until a particular 225 | condition is met. 226 | 227 | <>= 228 | (define*-public (block-until condition-thunk #:optional (serial? #f)) 229 | (if (not (run-thunk condition-thunk)) 230 | (run-thunk (abort-to-prompt 'block 'block-until 231 | condition-thunk serial?)))) 232 | @ 233 | 234 | \noindent And if we have [[block-until]], it's easy to write 235 | [[block-while]]. 236 | 237 | <>= 238 | (define*-public (block-while condition-thunk #:optional (serial? #f)) 239 | (block-until (negate condition-thunk) serial?)) 240 | @ 241 | 242 | Let's exercise this [[block-until]] procedure. 243 | <>= 244 | (define continue-blocking? #t) 245 | (define (i-block-until) 246 | (block-until (lambda () (not continue-blocking?)))) 247 | (check (length blocking-continuations) => 0) 248 | (call-blockable (lambda () (i-block-until))) 249 | (check (length blocking-continuations) => 1) 250 | @ 251 | 252 | \noindent Now, even if we call [[block-tick]] it shouldn't be resumed. 253 | 254 | <>= 255 | (block-tick) 256 | (check (length blocking-continuations) => 1) 257 | @ 258 | 259 | \noindent Let's change the condition for our blocking call. 260 | 261 | <>= 262 | (set! continue-blocking? #f) 263 | (check (length blocking-continuations) => 1) 264 | (block-tick) 265 | (check (length blocking-continuations) => 0) 266 | @ 267 | 268 | Sometimes we may just want to kill a blocking continuation. One could 269 | just forget the reference and let it be garbage collected. Here, 270 | we're going to throw an exception such that whatever the continuation 271 | was doing can potentially be cleaned up. 272 | 273 | <>= 274 | (define-method-public (block-kill (obj )) 275 | (set! (ran? obj) #t) 276 | (call-blockable 277 | (lambda () ((slot-ref obj 'continuation) 278 | (lambda () 279 | (throw 'block-killed obj) 280 | #f))))) 281 | @ 282 | 283 | \noindent Let's exercise [[block-kill]]. 284 | <>= 285 | (set! continue-blocking? #t) 286 | (let ((bc (call-blockable (lambda () (i-block-until))))) 287 | (check (length blocking-continuations) => 1) 288 | (block-tick) 289 | (check (length blocking-continuations) => 1) 290 | (check-throw (block-kill bc) => 'block-killed) 291 | ;; The killed block is not cleaned out immediately. 292 | (check (length blocking-continuations) => 1) 293 | (block-tick) 294 | (check (length blocking-continuations) => 0)) 295 | 296 | @ 297 | 298 | We're going to capture these blocking continuations into a class. 299 | 300 | <>= 301 | (define-class () 302 | (number #:getter number #:init-thunk (let ((count -1)) 303 | (lambda () (incr! count)))) 304 | (loop-number #:getter loop-number #:init-keyword #:loop-number) 305 | (tag #:getter tag #:init-keyword #:tag) 306 | (continuation #:init-keyword #:continuation) 307 | (continue-when? #:init-keyword #:continue-when?) 308 | (continue-now #:init-keyword #:continue-now) 309 | ;; Has this ran and ready to be deleted? 310 | (ran? #:accessor ran? #:init-value #f) 311 | (serial? #:getter serial? #:init-keyword #:serial? #:init-value #t)) 312 | 313 | (define-method (write (obj ) port) 314 | (write (string-concatenate 315 | (list "#string (tag obj)) 316 | " " (number->string (number obj)) 317 | " cl " (number->string (loop-number obj)) ">")) port)) 318 | @ 319 | 320 | \noindent There's a lot of information being 321 | 322 | 323 | 324 | \subsection*{Utilities} 325 | The [[incr!]] macro is just a little bit of syntactic sugar. 326 | 327 | <>= 328 | (define-syntax-public incr! 329 | (syntax-rules () 330 | ((incr! variable inc) 331 | (begin 332 | (set! variable (+ variable inc)) 333 | variable)) 334 | ((incr! variable) 335 | (incr! variable 1)))) 336 | @ 337 | 338 | <>= 339 | (define-syntax-public decr! 340 | (syntax-rules () 341 | ((decr! variable inc) 342 | (incr! variable (- inc))) 343 | ((decr! variable) 344 | (decr! variable 1)))) 345 | @ 346 | 347 | <>= 348 | (define-syntax-public cons! 349 | (syntax-rules () 350 | ((cons! elm list) 351 | (begin 352 | (set! list (cons elm list)) 353 | list)))) 354 | @ 355 | \subsection*{File Layout} 356 | 357 | <>= 358 | (define-module (emacsy block) 359 | #:use-module (ice-9 optargs) 360 | #:use-module (oop goops) 361 | #:use-module (emacsy util)) 362 | <> 363 | <> 364 | <> 365 | <> 366 | <> 367 | @ 368 | 369 | Layout for tests. 370 | <>= 371 | (use-modules (emacsy block) 372 | (oop goops)) 373 | 374 | (eval-when (compile load eval) 375 | ;; Some trickery so we can test private procedures. 376 | (module-use! (current-module) (resolve-module '(emacsy block)))) 377 | 378 | <<+ Test Preamble>> 379 | <> 380 | <<+ Test Postscript>> 381 | @ 382 | 383 | -------------------------------------------------------------------------------- /src/emacsy/command.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | \section{Command Module} 3 | 4 | \epigraph{If words of command are not clear and distinct, if orders are not thoroughly understood, then the general is to blame.}{Sun Tzu} 5 | 6 | The command module is responsible for a couple things. In Emacs one 7 | defines commands by using the special form [[(interactive)]] within 8 | the body of the procedure. Consider this simple command. 9 | 10 | \begin{verbatim} 11 | (defun hello-command () 12 | (interactive) 13 | (message "Hello, Emacs!")) 14 | \end{verbatim} 15 | 16 | Emacsy uses a more Scheme-like means of defining commands as shown 17 | below. 18 | 19 | \begin{verbatim} 20 | (define-interactive (hello-command) 21 | (message "Hello, Emacsy!")) 22 | \end{verbatim} 23 | 24 | One deviation from Emacs I want to see within Emacsy is to have the 25 | commands be more context sensitive. To illustrate the problem when I 26 | hit \verb|M-x TAB TAB| it autocompletes all the available commands 27 | into a buffer. In my case that buffer contains 4,840 commands. This 28 | doesn't seem to hurt command usability, but it does hurt the command 29 | discoverability. 30 | 31 | I want Emacsy to have command sets that are analogous to keymaps. 32 | There will be a global command set [[global-cmdset]] similar to the 33 | global keymap [[global-map]]. And in the same way that major and 34 | minor modes may add keymaps to a particular buffer, so too may they 35 | add command maps. 36 | 37 | \todo[inline]{Figure out where to look up any given 38 | function/variable using this kind of code (apropos-internal 39 | "\^emacsy.*"). Refer to ice-9 readline package for an example of 40 | its usage.} 41 | 42 | The class holds the entries, a string completer for tab completion, 43 | and potentially a parent command map. 44 | 45 | \todo[inline]{Wouldn't this better be thought of as a command set 46 | rather than map. Also, having it as a map means there could be two 47 | different implementations of the command; the one referred to by the 48 | procedure, and the one referred to in the map. They could be become 49 | unsynchronized.} 50 | 51 | <>= 52 | (define-class-public () 53 | (commands #:getter commands #:init-form (list)) 54 | (completer #:getter completer #:init-form (make )) 55 | (parent #:accessor parent #:init-keyword #:parent #:init-value #f)) 56 | (export commands completer) 57 | @ 58 | 59 | We have accessors for adding, removing, and testing what's in the 60 | set. Note that the parent set is never mutated. 61 | 62 | <>= 63 | (define-method-public (command-contains? (cmap ) command-symbol) 64 | (or (memq command-symbol (commands cmap)) 65 | (and (parent cmap) (command-contains? (parent cmap) command-symbol)))) 66 | 67 | (define-method-public (command-add! (cmap ) command-symbol) 68 | (when (not (command-contains? cmap command-symbol)) 69 | (add-strings! (completer cmap) (list (symbol->string command-symbol))) 70 | (slot-set! cmap 'commands (cons command-symbol (commands cmap))))) 71 | 72 | (define-method-public (command-remove! (cmap ) command-symbol) 73 | (when (command-contains? cmap command-symbol) 74 | (slot-set! cmap 'commands (delq! command-symbol (commands cmap))) 75 | ;; Must rebuild the completer. 76 | (let ((c (make ))) 77 | (add-strings! c (map symbol->string (commands cmap))) 78 | (slot-set! cmap 'completer c)))) 79 | @ 80 | 81 | We define the global command map. 82 | 83 | <>= 84 | (define-public global-cmdset (make )) 85 | @ 86 | 87 | \todo[inline]{Perhaps procedure-properties should be used to denote a 88 | procedure as a command?} 89 | 90 | <>= 91 | (define-public (module-command-interface mod) 92 | (unless (module-variable mod '%module-command-interface) 93 | (module-define! mod '%module-command-interface 94 | (let ((iface (make-module))) 95 | (set-module-name! iface (module-name mod)) 96 | (set-module-version! iface (module-version mod)) 97 | (set-module-kind! iface 'command) 98 | ;(module-use! iface (resolve-interface '(guile))) 99 | iface))) 100 | (module-ref mod '%module-command-interface)) 101 | 102 | 103 | 104 | (define-public (module-export-command! m names) 105 | (let ((public-i (module-command-interface m))) 106 | ;; Add them to this module. 107 | (for-each (lambda (name) 108 | (let* ((internal-name (if (pair? name) (car name) name)) 109 | (external-name (if (pair? name) (cdr name) name)) 110 | (var (module-ensure-local-variable! m internal-name))) 111 | (module-add! public-i external-name var))) 112 | names))) 113 | 114 | (define-syntax-rule (export-command name ...) 115 | (eval-when (eval load compile expand) 116 | (call-with-deferred-observers 117 | (lambda () 118 | (module-export-command! (current-module) '(name ...)))))) 119 | 120 | (define-syntax-public define-interactive 121 | (syntax-rules () 122 | ((define-interactive (name . args) . body) 123 | (begin (define-cmd global-cmdset (name . args) 124 | . body) 125 | (export-command name))) 126 | ((define-interactive name value) 127 | (begin (define-cmd global-cmdset name value) 128 | (export-command name)) 129 | ))) 130 | @ 131 | 132 | \todo[inline]{Need to fix: define-cmd doesn't respect documentation strings.} 133 | <>= 134 | (define-syntax-public define-cmd 135 | (lambda (x) 136 | (syntax-case x () 137 | ((define-cmd (name . args) e0) 138 | #'(begin 139 | (define* (name . args) 140 | (with-fluids ((in-what-command 'name)) 141 | e0)) 142 | (export name) 143 | (emacsy-kind-set! 144 | (module-variable (current-module) 'name) 145 | 'command) 146 | (set-command-properties! name 'name))) 147 | ((define-cmd (name . args) e0 e1 . body) 148 | (string? (syntax->datum #'e0)) 149 | ;; Handle the case where there is a documentation string. 150 | #'(begin 151 | (define* (name . args) 152 | e0 153 | (with-fluids ((in-what-command 'name)) 154 | (let () 155 | e1 . body))) 156 | (export name) 157 | (emacsy-kind-set! 158 | (module-variable (current-module) 'name) 159 | 'command) 160 | (set-command-properties! name 'name))) 161 | ((define-cmd (name . args) e0 e1 . body) 162 | #'(begin 163 | (define* (name . args) 164 | (with-fluids ((in-what-command 'name)) 165 | (let () 166 | e0 e1 . body))) 167 | (export name) 168 | (emacsy-kind-set! 169 | (module-variable (current-module) 'name) 170 | 'command) 171 | (set-command-properties! name 'name))) 172 | ((define-cmd name value) 173 | #'(begin 174 | (define name #f) 175 | (let ((v value)) 176 | (set! name (colambda args 177 | (with-fluids ((in-what-command 'name)) 178 | (apply v args)))) 179 | (export name) 180 | (emacsy-kind-set! 181 | (module-variable (current-module) 'name) 182 | 'command) 183 | (set-command-properties! name 'name)))) 184 | ((define-cmd cmap (name . args) . body) 185 | #'(begin 186 | (define-cmd (name . args) . body) 187 | (command-add! cmap 'name))) 188 | ((define-cmd cmap name value) 189 | #'(begin 190 | (define-cmd name value) 191 | (command-add! cmap 'name)))))) 192 | @ 193 | 194 | <>= 195 | (define-public (register-interactive name proc) 196 | (command-add! global-cmdset name) 197 | (set-command-properties! proc name)) 198 | @ 199 | 200 | <>= 201 | (define-public (command->proc command) 202 | (cond 203 | ((thunk? command) 204 | command) 205 | (else 206 | (warn "command->proc not given a command: ~a" command) 207 | #f))) 208 | @ 209 | 210 | <>= 211 | (define-public (command-name command) 212 | (procedure-name command)) 213 | @ 214 | 215 | <>= 216 | (define-public (command? object) 217 | (thunk? object)) 218 | @ 219 | 220 | \subsection{Determine Interactivity} 221 | 222 | We would like to be able to determine within the command procedure's 223 | body whether the command has been called interactively, by the user's 224 | key press, or by a keyboard macro or another procedure call. The best 225 | way I can think to do this is to have a means of answering the 226 | following questions: 1) What command am I in? 2) What is the current 227 | interactive command? 228 | 229 | Determining the current command is not that difficult. That's 230 | generally set by the [[this-command]] variable. However, determining 231 | what command I am in is a little troublesome. One can examine the 232 | stack and look for the first procedure that has some property 233 | associated with commands. 234 | 235 | <>= 236 | (define* (set-command-properties! proc #:optional (name #f)) 237 | (let ((cname (or name (procedure-name proc) #f))) 238 | (set-procedure-property! proc 'command-name 239 | (if (eq? cname 'proc) 240 | #f 241 | cname)))) 242 | @ 243 | 244 | <>= 245 | (define in-what-command (make-fluid #f)) 246 | @ 247 | 248 | <>= 249 | (define-syntax-public lambda-cmd 250 | (syntax-rules () 251 | ((lambda-cmd args . body) 252 | (let ((proc (lambda* args 253 | (with-fluids ((in-what-command #f)) 254 | . body)))) 255 | (set-command-properties! proc) 256 | proc)))) 257 | @ 258 | 259 | <>= 260 | (define test-cmd (lambda-cmd args 1)) 261 | (define (test-cmd-2) 2) 262 | (define-cmd (test-cmd-3) 3) 263 | (check (procedure-documentation test-cmd-3) => #f) 264 | (check (test-cmd) => 1) 265 | (check-true (command? test-cmd)) 266 | (check-true (command? test-cmd-2)) 267 | (check-true (command? test-cmd-3)) 268 | (check (assq-ref (procedure-properties test-cmd) 'command-name) => #f) 269 | (check (assq 'command-name (procedure-properties test-cmd-2)) => #f) 270 | (check (command-name test-cmd) => 'proc) 271 | (check (command-name test-cmd-2) => 'test-cmd-2) 272 | (check (command-name test-cmd-3) => 'test-cmd-3) 273 | @ 274 | 275 | <>= 276 | (define-public (what-command-am-i?) 277 | (fluid-ref in-what-command)) 278 | @ 279 | 280 | <>= 281 | (define-cmd (test-who-am-i?) 282 | "test-who-am-i? documentation" 283 | (let ((w (what-command-am-i?))) 284 | 1 285 | w)) 286 | (check (command-name test-who-am-i?) => 'test-who-am-i?) 287 | (check (test-who-am-i?) => 'test-who-am-i?) 288 | (check (procedure-documentation test-who-am-i?) => "test-who-am-i? documentation") 289 | @ 290 | 291 | <>= 292 | (define-public (command-execute command . args) 293 | (if (command? command) 294 | (let ((cmd-proc (command->proc command)) 295 | (cmd-name (command-name command))) 296 | (emacsy-log-info "Running command: ~a" cmd-name) 297 | (set! last-command this-command) 298 | (set! this-command cmd-name) 299 | (apply cmd-proc args)) 300 | (error (emacsy-log-warning "command-execute not given a command: ~a" command)))) 301 | @ 302 | 303 | <>= 304 | (define-public (emacsy-log-info format-msg . args) 305 | (apply format (current-error-port) format-msg args) 306 | (newline (current-error-port))) 307 | @ 308 | 309 | <>= 310 | (define-public this-command #f) 311 | (define-public last-command #f) 312 | @ 313 | 314 | <>= 315 | (define-public kill-rogue-coroutine? #f) 316 | (define-public seconds-to-wait-for-yield 2) 317 | @ 318 | 319 | <>= 320 | (define-public (call-interactively command . args) 321 | (dynamic-wind 322 | (lambda () (if kill-rogue-coroutine? 323 | (alarm seconds-to-wait-for-yield))) 324 | (lambda () (with-fluids ((this-interactive-command (command-name command))) 325 | (apply command-execute command args))) 326 | (lambda () (if kill-rogue-coroutine? 327 | (alarm 0))))) 328 | @ 329 | 330 | <>= 331 | (define this-interactive-command (make-fluid)) 332 | @ 333 | 334 | <>= 335 | (define*-public (called-interactively? #:optional (kind 'any)) 336 | (eq? (fluid-ref in-what-command) (fluid-ref this-interactive-command))) 337 | @ 338 | 339 | <>= 340 | (define-cmd (foo) 341 | (if (called-interactively?) 342 | 'interactive 343 | 'non-interactive)) 344 | (check (command? 'foo) => #f) 345 | (check (command? foo) => #t) 346 | (check (command-name foo) => 'foo) 347 | (check-true (command->proc foo)) 348 | 349 | (check-throw (command-execute 'foo) => 'misc-error) 350 | (check (command-execute foo) => 'non-interactive) 351 | (check (call-interactively foo) => 'interactive) 352 | @ 353 | 354 | 355 | \subsection*{File Layout} 356 | 357 | <>= 358 | (define-module (emacsy command) 359 | #:use-module (string completion) 360 | #:use-module (oop goops) 361 | #:use-module (ice-9 optargs) 362 | #:use-module (emacsy util) 363 | #:use-module (emacsy self-doc) 364 | #:use-module (emacsy coroutine) 365 | 366 | #:export-syntax (export-command)) 367 | <> 368 | <> 369 | <> 370 | <> 371 | <> 372 | @ 373 | 374 | Layout for tests. 375 | <>= 376 | (use-modules (emacsy command) 377 | (emacsy event) 378 | (oop goops)) 379 | 380 | (eval-when (compile load eval) 381 | ;; Some trickery so we can test private procedures. 382 | (module-use! (current-module) (resolve-module '(emacsy command)))) 383 | 384 | <<+ Test Preamble>> 385 | <> 386 | <<+ Test Postscript>> 387 | @ 388 | -------------------------------------------------------------------------------- /src/emacsy/coroutine-test.scm: -------------------------------------------------------------------------------- 1 | (use-modules (emacsy coroutine) 2 | (check)) 3 | 4 | (define a (make-coroutine 5 | (lambda () 6 | (couser-data) 7 | #;(yield (lambda (resume) 8 | (resume 'b) 9 | )) 10 | ;'a 11 | ) 12 | 'a 13 | 'a-user-data)) 14 | 15 | (check (a) => 'a-user-data) 16 | -------------------------------------------------------------------------------- /src/emacsy/coroutine.scm: -------------------------------------------------------------------------------- 1 | ;; https://github.com/davexunit/guile-2d/blob/master/2d/coroutine.scm 2 | ;; 3 | ;; I'm Shane. I'm having a problem trying to fix codefine*. I wrote 4 | ;; the strip-optargs macro to try to fix it, but I can't get it right. 5 | ;; Help me, #guile! 6 | 7 | ;;; guile-2d 8 | ;;; Copyright (C) 2013 David Thompson 9 | ;;; 10 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 11 | ;;; under the terms of the GNU Lesser General Public License as 12 | ;;; published by the Free Software Foundation, either version 3 of the 13 | ;;; License, or (at your option) any later version. 14 | ;;; 15 | ;;; Guile-2d is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 | ;;; Lesser General Public License for more details. 19 | ;;; 20 | ;;; You should have received a copy of the GNU Lesser General Public 21 | ;;; License along with this program. If not, see 22 | ;;; . 23 | 24 | ;;; Commentary: 25 | ;; 26 | ;; Cooperative multi-tasking. 27 | ;; 28 | ;;; Code: 29 | 30 | (define-module (emacsy coroutine) 31 | #:export (make-coroutine 32 | coroutine 33 | colambda 34 | codefine 35 | codefine* 36 | couser-data) 37 | #:replace (yield)) 38 | 39 | (define cid-next 0) 40 | 41 | ;; could have a (make-coroutine thunk) => (cid . run-coroutine-thunk) 42 | (define* (make-coroutine thunk #:optional (name #f) (user-data #f)) 43 | "Creates a procedure that can yield a continuation. (Does not execute thunk.)" 44 | (define cid cid-next) 45 | (define (handler cont key . args) 46 | (define (resume . args) 47 | (format #t "resuming ~a cid ~a~%" name cid) 48 | ;; Call continuation that resumes the procedure. 49 | (call-with-prompt 'coroutine-prompt 50 | (lambda () (apply cont args)) 51 | handler)) 52 | (when name 53 | (set-procedure-property! resume 54 | 'name (string->symbol 55 | (format #f "~a-resume-~a" name cid)))) 56 | (case key 57 | ((callback) 58 | (when (procedure? (car args)) 59 | (apply (car args) resume (cdr args)))) 60 | ((user-data) 61 | (resume user-data)))) 62 | (set! cid-next (1+ cid-next)) 63 | 64 | (lambda () (call-with-prompt 'coroutine-prompt thunk handler))) 65 | 66 | (define* (coroutine thunk #:optional (name #f) (user-data #f)) 67 | "Calls a procedure that can yield a continuation." 68 | ((make-coroutine thunk name user-data))) 69 | 70 | ;; emacs: (put 'colambda 'scheme-indent-function 0) 71 | (define-syntax-rule (colambda args body ...) 72 | "Syntacic sugar for a lambda that is run as a coroutine." 73 | (lambda args 74 | (coroutine 75 | (lambda () body ...)))) 76 | 77 | ;; emacs: (put 'codefine 'scheme-indent-function 1) 78 | (define-syntax-rule (codefine (name . args) . body) 79 | "Syntactic sugar for defining a procedure that is run as a 80 | coroutine." 81 | (define (name . args) 82 | ;; Create an inner procedure with the same signature so that a 83 | ;; recursive procedure call does not create a new prompt. 84 | (define (name . args) . body) 85 | (coroutine 86 | (lambda () (name . args)) 'name))) 87 | 88 | ;; (strip-optargs #'(a #:optional (b 2) c)) =>~ (a b c) 89 | ;; TODO make it work with keyword arguments. 90 | (define strip-optargs 91 | (lambda (x) 92 | (syntax-case x () 93 | (() 94 | #'()) 95 | ;; optional values 96 | (((v e) e2 ...) 97 | (identifier? #'v) 98 | #`(v . #,(strip-optargs #'(e2 ...)))) 99 | ;; #:optional keyword 100 | ((#:optional e2 ...) 101 | (strip-optargs #'(e2 ...))) 102 | ;; identifiers 103 | ((e1 e2 ...) 104 | (identifier? #'e1) 105 | #`(e1 . #,(strip-optargs #'(e2 ...))))))) 106 | 107 | ;; emacs: (put 'codefine* 'scheme-indent-function 1) 108 | "Syntactic sugar for defining a procedure with optional and 109 | keyword arguments that is run as a coroutine." 110 | #;(define-syntax codefine* 111 | (lambda (x) 112 | (syntax-case x () 113 | ((codefine* (name . args) . body) 114 | (with-syntax ((callable-args (strip-optargs #'args))) 115 | #'(define* (name . args) 116 | ;; Create an inner procedure with the same signature so that a 117 | ;; recursive procedure call does not create a new prompt. 118 | (define* (name . args) . body) 119 | (coroutine 120 | (lambda () (name . callable-args))))))))) 121 | 122 | ;; emacs: (put 'codefine* 'scheme-indent-function 1) 123 | #;(define-syntax-rule (codefine* (name . formals) . body) 124 | "Syntactic sugar for defining a procedure that is run as a 125 | coroutine." 126 | (define (name . args) 127 | ;; Create an inner procedure with the same signature so that a 128 | ;; recursive procedure call does not create a new prompt. 129 | (define* (name . formals) . body) 130 | (coroutine 131 | (lambda () (apply name args))))) 132 | 133 | ;; emacs: (put 'codefine* 'scheme-indent-function 1) 134 | ;; Thank Mark Weaver for defining this little gem without 135 | ;; the crazy syntax-case I originally did. -SEC 136 | #;(define-syntax-rule (codefine* (name . formals) . body) 137 | "Syntactic sugar for defining a procedure that is run as a 138 | coroutine." 139 | (define (name . args) 140 | ;; Create an inner procedure with the same signature so that a 141 | ;; recursive procedure call does not create a new prompt. 142 | (define* (name . formals) . body) 143 | (coroutine 144 | (lambda () (apply name args))))) 145 | 146 | ;; Syntactic sugar for defining a procedure that is run as a 147 | ;; coroutine. 148 | (define-syntax codefine* 149 | (lambda (x) 150 | (syntax-case x () 151 | ((_ (name . formals) e0) 152 | #'(define (name . args) 153 | ;; Create an inner procedure with the same signature so that a 154 | ;; recursive procedure call does not create a new prompt. 155 | (define* (name . formals) e0) 156 | (coroutine 157 | (lambda () (apply name args)) 158 | 'name))) 159 | ;; Handle the case where there is a documentation string. 160 | ((_ (name . formals) e0 e1 . body) 161 | (string? (syntax->datum #'e0)) 162 | #'(define (name . args) 163 | e0 164 | ;; Create an inner procedure with the same signature so that a 165 | ;; recursive procedure call does not create a new prompt. 166 | (define* (name . formals) e1 . body) 167 | (coroutine 168 | (lambda () (apply name args)) 169 | 'name))) 170 | ((_ (name . formals) e0 e1 . body) 171 | #'(define (name . args) 172 | ;; Create an inner procedure with the same signature so that a 173 | ;; recursive procedure call does not create a new prompt. 174 | (define* (name . formals) e0 e1 . body) 175 | (coroutine 176 | (lambda () (apply name args)) 177 | 'name)))))) 178 | 179 | (define (yield callback) 180 | "Yield continuation to a CALLBACK procedure." 181 | (abort-to-prompt 'coroutine-prompt 'callback callback)) 182 | 183 | (define (couser-data) 184 | "Return the user-data for this coroutine." 185 | (abort-to-prompt 'coroutine-prompt 'user-data)) 186 | -------------------------------------------------------------------------------- /src/emacsy/emacsy-c-api.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: c-mode -*- 2 | \chapter{C API} 3 | \lstset{language=C} 4 | 5 | Emacsy provides a C API to ease integration with C and C++ 6 | programs. The C API is given below. 7 | 8 | <>= 9 | /* Initialize Emacsy. */ 10 | int emacsy_initialize(int init_flags); 11 | 12 | /* Enqueue a keyboard event. */ 13 | void emacsy_key_event(int char_code, 14 | int modifier_key_flags); 15 | 16 | /* Enqueue a mouse event. */ 17 | void emacsy_mouse_event(int x, int y, 18 | int state, 19 | int button, 20 | int modifier_key_flags); 21 | 22 | /* Run an iteration of Emacsy's event loop 23 | (will not block). */ 24 | int emacsy_tick(); 25 | 26 | /* Return the message or echo area. */ 27 | char *emacsy_message_or_echo_area(); 28 | 29 | /* Return the mode line. */ 30 | char *emacsy_mode_line(); 31 | 32 | /* Return the name of the current buffer. */ 33 | char *emacsy_current_buffer(); 34 | 35 | /* Run a hook. */ 36 | int emacsy_run_hook_0(const char *hook_name); 37 | 38 | /* Return the minibuffer point. */ 39 | int emacsy_minibuffer_point(); 40 | 41 | /* Terminate Emacsy, runs termination hook. */ 42 | int emacsy_terminate(); 43 | 44 | /* Attempt to load a module. */ 45 | int emacsy_load_module(const char *module_name); 46 | 47 | /* Load a file in the emacsy environment. */ 48 | //int emacsy_load(const char *file_name); 49 | 50 | /* Convert the modifier_key_flags into a Scheme list of symbols. */ 51 | // Do I want to include any Scheme objects or keep it strictly C? 52 | #include 53 | SCM modifier_key_flags_to_list(int modifier_key_flags); 54 | @ 55 | <>= 56 | /* emacsy.h 57 | 58 | <<+ Copyright>> 59 | 60 | <<+ License>> 61 | */ 62 | 63 | <> 64 | 65 | <> 66 | 67 | <> 68 | 69 | <> 70 | 71 | @ Here are the constants for the C API. 72 | 73 | <>= 74 | #define EMACSY_MODKEY_COUNT 6 75 | 76 | #define EMACSY_MODKEY_ALT 1 // A 77 | #define EMACSY_MODKEY_CONTROL 2 // C 78 | #define EMACSY_MODKEY_HYPER 4 // H 79 | #define EMACSY_MODKEY_META 8 // M 80 | #define EMACSY_MODKEY_SUPER 16 // s 81 | #define EMACSY_MODKEY_SHIFT 32 // S 82 | 83 | #define EMACSY_MOUSE_BUTTON_DOWN 0 84 | #define EMACSY_MOUSE_BUTTON_UP 1 85 | #define EMACSY_MOUSE_MOTION 2 86 | 87 | #define EMACSY_INTERACTIVE 1 88 | #define EMACSY_NON_INTERACTIVE 0 89 | 90 | @ Here are the return flags that may be returned by \verb|emacsy_tick|. 91 | 92 | <>= 93 | #define EMACSY_QUIT_APPLICATION_P 1 94 | #define EMACSY_ECHO_AREA_UPDATED_P 2 95 | #define EMACSY_MODELINE_UPDATED_P 4 96 | #define EMACSY_RAN_UNDEFINED_COMMAND_P 8 97 | @ The boilerplate guards so that a C++ program may include 98 | \verb|emacsy.h| are given below. 99 | 100 | <>= 101 | #ifdef __cplusplus 102 | extern "C" { 103 | #endif 104 | <>= 105 | #ifdef __cplusplus 106 | } 107 | #endif 108 | @ The implementation of the API calls similarly named Scheme procedures. 109 | 110 | \section{emacsy\_initialize} 111 | 112 | <>= 113 | int emacsy_initialize(int init_flags) 114 | { 115 | /* Load the (emacsy emacsy) module. */ 116 | const char *module = "emacsy emacsy"; 117 | int err = emacsy_load_module(module); 118 | if (err) 119 | return err; 120 | 121 | (void) scm_call_1(scm_c_public_ref("emacsy emacsy", "emacsy-initialize"), 122 | (init_flags & EMACSY_INTERACTIVE) ? SCM_BOOL_T : SCM_BOOL_F); 123 | 124 | return err; 125 | } 126 | @ The function [[scm_c_use_module]] throws an exception if it cannot 127 | find the module, so we have to split that functionality into a body 128 | function [[load_module_try]] and an error handler [[load_module_error]]. 129 | 130 | <>= 131 | SCM load_module_try(void *data) 132 | { 133 | scm_c_use_module((const char *)data); 134 | return scm_list_1(SCM_BOOL_T); 135 | } 136 | @ 137 | 138 | <>= 139 | SCM load_module_error(void *data, SCM key, SCM args) 140 | { 141 | //fprintf(stderr, "error: Unable to load module (%s).\n", (const char*) data); 142 | return scm_list_3(SCM_BOOL_F, key, args); 143 | } 144 | @ 145 | 146 | Attempt to load a module. Returns 0 if no errors, and non-zero otherwise. 147 | 148 | <>= 149 | int emacsy_load_module(const char *module) 150 | { 151 | SCM result = scm_internal_catch(SCM_BOOL_T, 152 | load_module_try, (void *) module, 153 | load_module_error, (void *) module); 154 | if (scm_is_false(scm_car(result))) { 155 | fprintf(stderr, "error: Unable to load module (%s); got error to key %s with args %s. Try setting the " 156 | "GUILE_LOAD_PATH environment variable.\n", module, 157 | scm_to_locale_string(scm_car(scm_cdr(result))), 158 | scm_to_locale_string(scm_car(scm_cdr(scm_cdr(result)))) 159 | ); 160 | return 1; //EMACSY_ERR_NO_MODULE; 161 | } 162 | return 0; 163 | } 164 | 165 | @ \section{emacsy\_key\_event} 166 | 167 | <>= 168 | void emacsy_key_event(int char_code, 169 | int modifier_key_flags) 170 | { 171 | SCM i = scm_from_int(char_code); 172 | //fprintf(stderr, "i = %d\n", scm_to_int(i)); 173 | SCM c = scm_integer_to_char(i); 174 | //fprintf(stderr, "c = %d\n", scm_to_int(scm_char_to_integer(c))); 175 | 176 | (void) scm_call_2(scm_c_public_ref("emacsy emacsy", "emacsy-key-event"), 177 | c, 178 | modifier_key_flags_to_list(modifier_key_flags)); 179 | } 180 | @ \section{emacsy\_mouse\_event} 181 | 182 | <>= 183 | void emacsy_mouse_event(int x, int y, 184 | int state, 185 | int button, 186 | int modifier_key_flags) 187 | { 188 | 189 | SCM down_sym = scm_c_string_to_symbol("down"); 190 | SCM up_sym = scm_c_string_to_symbol("up"); 191 | SCM motion_sym = scm_c_string_to_symbol("motion"); 192 | SCM state_sym; 193 | switch(state) { 194 | case EMACSY_MOUSE_BUTTON_UP: state_sym = up_sym; break; 195 | case EMACSY_MOUSE_BUTTON_DOWN: state_sym = down_sym; break; 196 | case EMACSY_MOUSE_MOTION: state_sym = motion_sym; break; 197 | default: 198 | fprintf(stderr, "warning: mouse event state received invalid input %d.\n", 199 | state); 200 | return; 201 | } 202 | 203 | (void) scm_call_3(scm_c_public_ref("emacsy emacsy", "emacsy-mouse-event"), 204 | scm_vector(scm_list_2(scm_from_int(x), 205 | scm_from_int(y))), 206 | scm_from_int(button), 207 | state_sym); 208 | } 209 | @ \section{emacsy\_tick} 210 | 211 | <>= 212 | int emacsy_tick() 213 | { 214 | int flags = 0; 215 | (void) scm_call_0(scm_c_public_ref("emacsy emacsy", 216 | "emacsy-tick")); 217 | if (scm_is_true(scm_c_public_ref("emacsy emacsy", 218 | "emacsy-quit-application?"))) 219 | flags |= EMACSY_QUIT_APPLICATION_P; 220 | if (scm_is_true(scm_c_public_ref("emacsy emacsy", 221 | "emacsy-ran-undefined-command?"))) 222 | flags |= EMACSY_RAN_UNDEFINED_COMMAND_P; 223 | 224 | return flags; 225 | } 226 | 227 | @ \section{emacsy\_message\_or\_echo\_area} 228 | 229 | <>= 230 | char *emacsy_message_or_echo_area() 231 | { 232 | return scm_to_locale_string( 233 | scm_call_0(scm_c_public_ref("emacsy emacsy", 234 | "emacsy-message-or-echo-area"))); 235 | } 236 | @ %def emacsy_message_or_echo_area 237 | 238 | \section{emacsy\_current\_buffer} 239 | 240 | <>= 241 | char *emacsy_current_buffer() 242 | { 243 | return scm_to_locale_string( 244 | scm_call_1(scm_c_public_ref("emacsy emacsy", "buffer-name"), 245 | scm_call_0(scm_c_public_ref("emacsy emacsy", 246 | "current-buffer")))); 247 | } 248 | @ %def emacsy_message_or_echo_area 249 | 250 | 251 | \section{emacsy\_mode\_line} 252 | 253 | \todo[inline]{Keep name as modeline.} 254 | <>= 255 | char *emacsy_mode_line() 256 | { 257 | return scm_to_locale_string( 258 | scm_call_0(scm_c_public_ref("emacsy emacsy", 259 | "emacsy-mode-line"))); 260 | } 261 | @ \section{emacsy\_terminate} 262 | 263 | <>= 264 | int emacsy_terminate() 265 | { 266 | SCM result; 267 | result = scm_call_0(scm_c_public_ref("emacsy emacsy", 268 | "emacsy-terminate")); 269 | return 0; 270 | } 271 | <>= 272 | #include "emacsy.h" 273 | #include 274 | 275 | <> 276 | 277 | <> 278 | @ 279 | <>= 280 | int emacsy_run_hook_0(const char *hook_name) 281 | { 282 | /* This should be protected from all sorts of errors that the hooks 283 | could throw. */ 284 | SCM result; 285 | result = scm_call_1(scm_c_public_ref("emacsy emacsy", 286 | "emacsy-run-hook"), 287 | scm_c_private_ref("guile-user", 288 | hook_name)); 289 | return 0; 290 | } 291 | <>= 292 | int emacsy_minibuffer_point() 293 | { 294 | return scm_to_int( 295 | scm_call_0(scm_c_public_ref("emacsy emacsy", 296 | "emacsy-minibuffer-point"))); 297 | } 298 | <>= 299 | SCM scm_c_string_to_symbol(const char* str) { 300 | return scm_string_to_symbol(scm_from_locale_string(str)); 301 | } 302 | 303 | SCM modifier_key_flags_to_list(int modifier_key_flags) 304 | { 305 | const char* modifiers[] = { "alt", "control", "hyper", "meta", "super", "shift" }; 306 | SCM list = SCM_EOL; 307 | for (int i = 0; i < EMACSY_MODKEY_COUNT; i++) { 308 | if (modifier_key_flags & (1 @<< i)) { 309 | list = scm_cons(scm_c_string_to_symbol(modifiers[i]), list); 310 | } 311 | } 312 | 313 | return list; 314 | } 315 | 316 | SCM_DEFINE(scm_modifier_key_flags_to_list, "modifier-key-flags->list", 317 | 1, 0, 0, 318 | (SCM flags), 319 | "Convert an integer of modifier key flags to a list of symbols.") 320 | { 321 | int modifier_key_flags = scm_to_int(flags); 322 | return modifier_key_flags_to_list(modifier_key_flags); 323 | } 324 | @ 325 | -------------------------------------------------------------------------------- /src/emacsy/event.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | \section{Event Module} 3 | 4 | Let's define an root event class. \todo{Rename time to event-time.} 5 | 6 | <>= 7 | (define-class-public () 8 | (time #:getter time #:init-thunk (lambda () (emacsy-time))) 9 | (discrete-event? #:getter discrete-event? #:init-keyword #:discrete-event? #:init-value #t)) 10 | (export time discrete-event?) 11 | @ 12 | 13 | This defines the class [[]]. It relies on [[emacsy-time]] that 14 | I'm going to place in a utilities module, which will be mostly a 15 | bucket of miscellaneous things that any module might end up making use 16 | of. 17 | 18 | <>= 19 | (define-public (emacsy-time) 20 | (exact->inexact (/ (tms:clock (times)) internal-time-units-per-second))) 21 | @ 22 | 23 | \subsection{Key Event} 24 | Now let's give ourselves an event that'll capture key strokes 25 | including the modifier keys. 26 | 27 | <>= 28 | (define-class-public () 29 | (modifier-keys #:getter modifier-keys 30 | #:init-keyword #:modifier-keys 31 | #:init-value '())) 32 | 33 | (define-class-public () 34 | (command-char #:getter command-char 35 | #:init-keyword #:command-char)) 36 | (export modifier-keys command-char) 37 | @ 38 | 39 | <>= 40 | (check-true (make #:command-char #\a)) 41 | @ 42 | 43 | One of the idioms we want to capture from Emacs is this. 44 | 45 | \begin{verbatim} 46 | (define-key global-map "M-f" 'some-command) 47 | \end{verbatim} 48 | 49 | They [[keymap]] and [[command]] module will deal with most of the 50 | above, except for the [[kbd]] procedure. That's something events will 51 | be concerned with. One may define a converter for a [[kbd-entry]] to 52 | an event of the proper type. Note that a [[kbd-string]] is broken 53 | into multiple [[kbd-entries]] on whitespace boundaries, e.g., ``C-x 54 | C-f'' is a [[kbd-string]] that when parsed becomes two [[kbd-entries]] 55 | ``C-x'' and ``C-f''. 56 | 57 | 58 | 59 | Let's write the converter for the [[]] class that will 60 | accept the same kind of strings that Emacs does. If the [[kbd-entry]] 61 | does not match the event-type, we return false [[#f]]. 62 | 63 | <>= 64 | (define (kbd-entry->key-event kbd-entry) 65 | (match (strip-off-modifier-keys kbd-entry) 66 | ((mod-keys kbd-entry) 67 | (let ((regex "^([^ ]|RET|DEL|ESC|TAB|SPC)$")) 68 | (let ((match (string-match regex kbd-entry))) 69 | (if match 70 | (let* ((char (string->command-char (match:substring match 1)))) 71 | (make #:command-char char #:modifier-keys mod-keys)) 72 | #f)))))) 73 | 74 | (define (get-modifier-keys str) 75 | (if str 76 | (map modifier-char->symbol 77 | (filter (lambda (x) (not (char=? x #\-))) (string->list str))) 78 | '())) 79 | 80 | (define-public (strip-off-modifier-keys kbd-entry) 81 | "Parse the kbd-entry and strip off the modifier-keys and return the kbd-entry 82 | and a list of modifier keys." 83 | (let ((regex "^(([ACHMsS]-)*)(.*)$")) 84 | (let ((match (string-match regex kbd-entry))) 85 | (if match 86 | (let ((mod-keys (get-modifier-keys (match:substring match 1)))) 87 | (list mod-keys (match:substring match 3))) 88 | (list '() kbd-entry))))) 89 | @ 90 | 91 | <>= 92 | (check (strip-off-modifier-keys "C-a") => '((control) "a")) 93 | (check (strip-off-modifier-keys "a") => '(() "a")) 94 | (check (strip-off-modifier-keys "asdf") => '(() "asdf")) 95 | @ 96 | 97 | For the modifier keys, we are going to emulate Emacs to a fault. 98 | 99 | <>= 100 | (define-public (modifier-char->symbol char) 101 | (case char 102 | ((#\A) 'alt) 103 | ((#\C) 'control) 104 | ((#\H) 'hyper) 105 | ((#\M) 'meta) 106 | ((#\s) 'super) 107 | ((#\S) 'shift) 108 | (else (warn (format #f "Invalid character for modifier key: ~a" char)) 109 | #f))) 110 | @ 111 | 112 | <>= 113 | (check (modifier-char->symbol #\S) => 'shift) 114 | (check (modifier-char->symbol #\X) => #f) 115 | @ 116 | 117 | <>= 118 | (define (string->command-char str) 119 | (if (= (string-length str) 1) 120 | ;; One character string, return first character; simple! 121 | (string-ref str 0) 122 | (string-case str 123 | ("RET" #\cr) 124 | ("DEL" #\del) 125 | ("ESC" #\esc) 126 | ("TAB" #\tab) 127 | ("SPC" #\space) 128 | (else (warn (format #f "Invalid command character: ~a" str)) )))) 129 | @ 130 | 131 | Now we have the function [[kbd-entry->key-event]]. [[kbd]] needs to 132 | know about this and any other converter function. So let's register it. 133 | 134 | <>= 135 | (define kbd-converter-functions '()) 136 | @ 137 | 138 | <>= 139 | (define-public (register-kbd-converter function-name function) 140 | (set! kbd-converter-functions 141 | (assq-set! kbd-converter-functions function-name function))) 142 | @ 143 | 144 | Now we can register it. 145 | 146 | <>= 147 | (register-kbd-converter 'kbd-entry->key-event kbd-entry->key-event) 148 | @ 149 | 150 | Rather than doing this for every given converter, let's just write a 151 | macro. 152 | 153 | <>= 154 | (define-syntax-public define-kbd-converter 155 | (syntax-rules () 156 | ((define-kbd-converter (name args ...) expr ...) 157 | (begin (define* (name args ...) 158 | expr ...) 159 | (register-kbd-converter 'name name))) 160 | ((define-kbd-converter name value) 161 | (begin (define* name value) 162 | (register-kbd-converter 'name name))))) 163 | @ 164 | 165 | <>= 166 | (check-true (memq 'kbd-entry->key-event (alist-keys kbd-converter-functions))) 167 | @ 168 | 169 | One issue we have with the above is the following: 170 | 171 | <>= 172 | (check (modifier-keys (kbd-entry->key-event "C-C-C-x")) => '(control control control)) 173 | @ 174 | 175 | Our code doesn't account for duplicate modifier keys. For the keymap, 176 | we want a unique identifier of an event. Rather than massaging the 177 | conversion while in its string form, it seems reasonable to convert 178 | the [[kbd-entry]] into an event, then make the event canonical, then 179 | convert back into a string. [[kbd]] will look like this: 180 | 181 | <>= 182 | (define*-public (kbd key-string #:optional (canonical? #t)) 183 | (if canonical? 184 | (map event->kbd (map canonize-event! (kbd->events key-string))) 185 | (map event->kbd (kbd->events key-string)))) 186 | @ 187 | 188 | <>= 189 | (define (kbd-entry->event kbd-entry) 190 | (or (find-first (lambda (f) (f kbd-entry)) 191 | (alist-values kbd-converter-functions)) 192 | (throw 'invalid-kbd-entry kbd-entry))) 193 | @ 194 | 195 | The procedure [[find-first]] is similar to [[find]]; however, 196 | [[(find-first f (x . xs))]] returns the first [[(f x)]] that not false 197 | rather than the first [[x]] for which [[(f x)]] is true. 198 | 199 | <>= 200 | (define-public (find-first f lst) 201 | "Return the first result f which is not false and #f if no such result is found." 202 | (if (null? lst) 203 | #f 204 | (or (f (car lst)) 205 | (find-first f (cdr lst))))) 206 | @ 207 | 208 | <>= 209 | (define-public (alist-values alist) 210 | (map cdr alist)) 211 | 212 | (define-public (alist-keys alist) 213 | (map car alist)) 214 | @ 215 | 216 | 217 | <>= 218 | (define-public (kbd->events kbd-string) 219 | (let ((kbd-entries (string-tokenize kbd-string))) 220 | (map kbd-entry->event kbd-entries))) 221 | @ 222 | 223 | <>= 224 | (define-method-public (canonize-event! (event )) 225 | <> 226 | (let ((mod-keys (modifier-keys event))) 227 | ;; Put them in alphabetical order: ACHMsS. 228 | (slot-set! event 'modifier-keys 229 | (intersect-order mod-keys 230 | '(alt control hyper meta super shift)))) 231 | event) 232 | @ 233 | 234 | <>= 235 | (define-public (intersect-order list ordered-list ) 236 | "Returns the intersection of the two lists ordered according to the 237 | second argument." 238 | (filter (lambda (x) (memq x list)) 239 | ordered-list)) 240 | @ 241 | 242 | <>= 243 | (if (memq 'shift (modifier-keys event)) 244 | (if (char-set-contains? char-set:requires-shift-key (command-char event)) 245 | ;; Remove extraneous shift. 246 | (slot-set! event 'modifier-keys (delq 'shift (modifier-keys event))) 247 | ;; No shift required, but there is a shift in the kbd-entry. 248 | (if (char-lower-case? (command-char event)) 249 | (begin 250 | ;; Change the character to uppercase. 251 | (slot-set! event 'command-char (char-upcase (command-char event))) 252 | ;; Get rid of the shift. 253 | (slot-set! event 'modifier-keys (delq 'shift (modifier-keys event))))))) 254 | @ 255 | 256 | Let's test our canonization of a properly formed but non-canonical event. 257 | 258 | <>= 259 | (let ((key-event (kbd-entry->event "S-C-C-S-a"))) 260 | (check (modifier-keys key-event) => '(shift control control shift)) 261 | (check (command-char key-event) => #\a) 262 | (canonize-event! key-event) 263 | (check (modifier-keys key-event) => '(control)) 264 | (check (command-char key-event) => #\A)) 265 | @ 266 | 267 | <>= 268 | (check (kbd "S-C-C-S-a") => '("C-A")) 269 | (check (kbd "S-C-C-S-A") => '("C-A")) 270 | @ 271 | 272 | 273 | <>= 274 | (define char-set:requires-shift-key (char-set-union 275 | char-set:symbol 276 | char-set:upper-case 277 | (char-set-delete char-set:punctuation 278 | ;punctuation = !"#%&'()*,-./:;?@[\\]_{} 279 | #\. #\; #\[ #\] #\, #\' #\\))) 280 | @ 281 | 282 | Now we convert the [[]] back to a [[kbd-entry]]. 283 | 284 | <>= 285 | (define-method-public (event->kbd (event )) 286 | (let ((mods (next-method)) 287 | (cmd-char (command-char->string (command-char event)))) 288 | (format #f "~a~a" mods cmd-char))) 289 | 290 | (define-method-public (event->kbd (event )) 291 | (let ((mods (map string (map modifier-symbol->char (modifier-keys event))))) 292 | (string-join `(,@mods "") "-"))) 293 | @ 294 | 295 | <>= 296 | (check (event->kbd (make #:command-char #\a)) => "a") 297 | @ 298 | 299 | Instead of using [[define-generic]] I've written a convenience macro 300 | [[define-generic-public]] that exports the symbol to the current 301 | module. This mimics the functionality of [[define-public]]. In 302 | general, any *-public macro will export the symbol or syntax to the 303 | current module. 304 | 305 | <>= 306 | (define-public (modifier-symbol->char sym) 307 | (case sym 308 | ((alt) #\A) 309 | ((control) #\C) 310 | ((hyper) #\H) 311 | ((meta) #\M) 312 | ((super) #\s) 313 | ((shift) #\S) 314 | (else (error "Bad modifier symbol " sym)))) 315 | @ 316 | 317 | <>= 318 | (define (command-char->string c) 319 | (case c 320 | ((#\cr #\newline) "RET") 321 | ((#\del) "DEL") 322 | ((#\esc) "ESC") 323 | ((#\tab) "TAB") 324 | ((#\space) "SPC") 325 | (else (string c)))) 326 | @ 327 | 328 | <>= 329 | (check (event->kbd (make #:command-char #\a 330 | #:modifier-keys '(control))) => "C-a") 331 | @ 332 | 333 | Now we can display the [[]] in a nice way. 334 | 335 | <>= 336 | (define-method (write (obj ) port) 337 | (display "#kbd obj) port) 339 | (display ">" port)) 340 | @ 341 | 342 | A few procedures to determine whether what kind of objects is nice. 343 | 344 | <>= 345 | (define-public (event? obj) 346 | (is-a? obj )) 347 | 348 | (define-public (key-event? obj) 349 | (is-a? obj )) 350 | @ 351 | 352 | \subsection{Mouse Event} 353 | 354 | We also want to be able to deal with mouse events captured by the 355 | class [[]]. 356 | 357 | <>= 358 | (define-class-public () 359 | (modifier-keys #:getter modifier-keys #:init-keyword #:modifier-keys #:init-value '()) 360 | (position #:getter position #:init-keyword #:position) 361 | (button #:getter button #:init-keyword #:button) 362 | (state #:getter state #:init-keyword #:state)) 363 | (export modifier-keys position button state) 364 | @ 365 | 366 | Mouse drags require a little bit of extra information, for that we 367 | have the [[]] class. 368 | 369 | <>= 370 | (define-class-public () 371 | (rect #:getter rect #:init-keyword #:rect)) 372 | @ 373 | 374 | <>= 375 | (define-method (canonize-event! (event )) 376 | (let ((mod-keys (modifier-keys event))) 377 | ;; Put them in alphabetical order: ACHMsS. 378 | (slot-set! event 'modifier-keys 379 | (intersect-order mod-keys 380 | '(alt control hyper meta super shift))) 381 | event)) 382 | @ 383 | 384 | The [[kbd-entry]] for mouse events is similar to key events. The 385 | regular expression is 386 | \verb|^(([ACHMsS]-)*)((up-|down-|drag-)?mouse-([123]))\$|. 387 | 388 | <>= 389 | (define-kbd-converter (kbd-entry->mouse-event kbd-entry) 390 | (let* ((regex "^(([ACHMsS]-)*)((up-|down-|drag-)?mouse-([123]))$") 391 | (match (string-match regex kbd-entry))) 392 | (if match 393 | (let* ((symbol (string->symbol (match:substring match 3))) 394 | (modifier-keys (get-modifier-keys (match:substring match 1)))) 395 | ;; Warning that symbol is not used; squelch with this noop ref. 396 | symbol 397 | <>) 398 | ;; It doesn't specify a mouse event; return false. 399 | #f))) 400 | @ 401 | 402 | <>= 403 | (make #:position #f 404 | #:button (string->number (match:substring match 5)) 405 | #:state (let ((state-string (match:substring match 4))) 406 | (if state-string 407 | (string->symbol 408 | (string-trim-right state-string #\-)) 409 | 'click)) 410 | #:modifier-keys modifier-keys) 411 | @ 412 | 413 | <>= 414 | (define-method (event->kbd (event )) 415 | (define (state->list state) 416 | (case state 417 | ((up down drag) 418 | (list (symbol->string state))) 419 | ((click) 420 | '()) 421 | (else 422 | (error "Bad state state for mouse event " state)))) 423 | (let ((mods (map string (map modifier-symbol->char (modifier-keys event)))) 424 | (state-list (state->list (state event)))) 425 | (string-join 426 | `(,@mods ,@state-list "mouse" ,(number->string (button event))) 427 | "-"))) 428 | @ 429 | 430 | <>= 431 | (check (kbd "mouse-1") => '("mouse-1")) 432 | (check (kbd "S-S-mouse-1") => '("S-mouse-1")) 433 | @ 434 | 435 | Finally, let's add some interrogative procedures that mirror Emacs'. 436 | 437 | <>= 438 | (define*-public (mouse-event? obj #:optional (of-state #f)) 439 | (and (is-a? obj ) 440 | (if of-state 441 | (eq? of-state (state obj)) 442 | #t))) 443 | 444 | (define-public (up-mouse-event? e) 445 | (mouse-event? e 'up)) 446 | 447 | (define-public (down-mouse-event? e) 448 | (mouse-event? e 'down)) 449 | 450 | (define-public (drag-mouse-event? e) 451 | (mouse-event? e 'drag)) 452 | 453 | (define-public (click-mouse-event? e) 454 | (mouse-event? e 'click)) 455 | 456 | (define-public (motion-mouse-event? e) 457 | (mouse-event? e 'motion)) 458 | @ 459 | 460 | \subsection{Dummy Event} 461 | 462 | Finally, have a dummy event, which is useful to record when used 463 | temporal macros. 464 | 465 | \todo[inline]{This should probably be placed in the [[kbd-macro]] module.} 466 | 467 | <>= 468 | (define-class-public ()) 469 | @ 470 | 471 | <>= 472 | (define-method (canonize-event! (event )) 473 | event) 474 | 475 | (define-method (event->kbd (event )) 476 | #f) 477 | @ 478 | 479 | \subsection*{File Layout} 480 | 481 | <>= 482 | (define-module (emacsy event) 483 | #:use-module (ice-9 q) 484 | #:use-module (ice-9 regex) 485 | #:use-module (ice-9 optargs) 486 | ; #:use-module (srfi srfi-1) 487 | #:use-module (ice-9 match) 488 | #:use-module (oop goops) 489 | #:use-module (emacsy util) 490 | ) 491 | <> 492 | <> 493 | <> 494 | <> 495 | <> 496 | @ 497 | 498 | Layout for tests. 499 | <>= 500 | (use-modules (emacsy event) 501 | (oop goops) 502 | ) 503 | 504 | (eval-when (compile load eval) 505 | ;; Some trickery so we can test private procedures. 506 | (module-use! (current-module) (resolve-module '(emacsy event)))) 507 | 508 | <<+ Test Preamble>> 509 | <> 510 | <<+ Test Postscript>> 511 | @ 512 | -------------------------------------------------------------------------------- /src/emacsy/help.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | \section{Help} 3 | 4 | 5 | 6 | <>= 7 | (define-module (emacsy help) 8 | #:use-module (emacsy self-doc) 9 | #:use-module (emacsy keymap) 10 | #:use-module (emacsy klecl) 11 | #:use-module (emacsy command) 12 | #:use-module (emacsy minibuffer) 13 | #:use-module (emacsy core)) 14 | 15 | <> 16 | <> 17 | <> 18 | <> 19 | @ 20 | 21 | <>= 22 | (define-interactive 23 | (describe-variable 24 | #:optional 25 | (symbol (completing-read 26 | "Describe variable: " 27 | (emacsy-collect-kind (current-module) 'variable 1) 28 | #:to-string symbol->string))) 29 | #;(message "Describing variable ~a: ~a" symbol (variable-documentation symbol)) 30 | (message "~a" (variable-documentation symbol))) 31 | 32 | (define-interactive 33 | (describe-command 34 | #:optional 35 | (symbol (completing-read 36 | "Describe command: " 37 | (emacsy-collect-kind (current-module) 'command 1) 38 | #:to-string symbol->string))) 39 | #;(message "Describing variable ~a: ~a" symbol (variable-documentation symbol)) 40 | (message "~a" (procedure-documentation (module-ref (current-module) symbol)))) 41 | @ 42 | 43 | <>= 44 | 45 | (define-key global-map "C-h v" 'describe-variable) 46 | (define-key global-map "C-h c" 'describe-command) 47 | @ 48 | 49 | <>= 50 | (use-modules (check) 51 | (emacsy help)) 52 | (use-private-modules (emacsy help)) 53 | 54 | <> 55 | 56 | (check-exit) 57 | @ 58 | -------------------------------------------------------------------------------- /src/emacsy/job-test.scm: -------------------------------------------------------------------------------- 1 | (use-modules (emacsy coroutine) 2 | (emacsy agenda) 3 | (emacsy job) 4 | (ice-9 receive) 5 | (check)) 6 | 7 | (use-private-modules (emacsy job)) 8 | 9 | (set! next-job-id 1) 10 | 11 | (check *current-job-list* => '()) 12 | 13 | (define a (make-job (lambda () 14 | (get-job-id)))) 15 | 16 | 17 | (check *current-job-list* => (list (%make-job 1 'baby #f #f))) 18 | 19 | (check (a) => 1) 20 | 21 | (check *current-job-list* => (list (%make-job 1 'zombie 1 #f))) 22 | 23 | (check-throw (a) => 'job-already-started) 24 | 25 | (check *current-job-list* => (list (%make-job 1 'zombie 1 #f))) 26 | 27 | (set! *current-job-list* '()) 28 | 29 | (define b (make-job (lambda () 30 | 1 31 | (wait) 32 | 2))) 33 | 34 | (check *current-job-list* => (list (%make-job 2 'baby #f #f))) 35 | (check (b) => *unspecified*) 36 | (check *current-job-list* => (list (%make-job 2 'running #f #f))) 37 | (check-throw (b) => 'job-already-started) 38 | (check *current-job-list* => (list (%make-job 2 'running #f #f))) 39 | (update-agenda) 40 | (check *current-job-list* => (list (%make-job 2 'zombie 2 #f))) 41 | 42 | (set! *current-job-list* '()) 43 | 44 | (define c (make-job (lambda () 45 | 1 46 | (wait) 47 | 2))) 48 | 49 | (check *current-job-list* => (list (%make-job 3 'baby #f #f))) 50 | (check (c) => *unspecified*) 51 | (check *current-job-list* => (list (%make-job 3 'running #f #f))) 52 | (check-throw (c) => 'job-already-started) 53 | (check *current-job-list* => (list (%make-job 3 'running #f #f))) 54 | (suspend-job (car *current-job-list*)) 55 | (check *current-job-list* => (list (%make-job 3 'suspended #f #f))) 56 | (update-agenda) 57 | (check (job-state (car *current-job-list*)) => 'suspended) 58 | (continue-job (car *current-job-list*)) 59 | (check *current-job-list* => (list (%make-job 3 'running #f #f))) 60 | (update-agenda) 61 | (check *current-job-list* => (list (%make-job 3 'zombie 2 #f))) 62 | 63 | (set! *current-job-list* '()) 64 | 65 | (define d (make-job (lambda () 66 | 1 67 | (job-exit 3) 68 | 2))) 69 | 70 | (check *current-job-list* => (list (%make-job 4 'baby #f #f))) 71 | (check (d) => 3) 72 | (check *current-job-list* => (list (%make-job 4 'zombie 3 #f))) 73 | 74 | (set! *current-job-list* '()) 75 | 76 | (define e (make-job 77 | (lambda () 78 | (receive (proc job) 79 | (make-job (lambda () 80 | (wait) 81 | 'f)) 82 | (wait) 83 | (proc) 84 | (wait-for-job job))))) 85 | 86 | 87 | (check *current-job-list* => (list (%make-job 5 'baby #f #f))) 88 | (e) 89 | (check *current-job-list* => (list (%make-job 6 'baby #f #f) 90 | (%make-job 5 'running #f #f))) 91 | (update-agenda) 92 | (check *current-job-list* => (list (%make-job 6 'running #f #f) 93 | (%make-job 5 'running #f #f))) 94 | (update-agenda) 95 | (check *current-job-list* => (list (%make-job 6 'zombie 'f #f) 96 | (%make-job 5 'zombie 'f #f))) 97 | 98 | (check (format #f "~a" (car *current-job-list*)) => "#") 99 | 100 | (check-report) 101 | (check-exit) 102 | -------------------------------------------------------------------------------- /src/emacsy/job.scm: -------------------------------------------------------------------------------- 1 | (define-module (emacsy job) 2 | #:use-module (srfi srfi-1) 3 | #:use-module (srfi srfi-9) 4 | #:use-module (srfi srfi-9 gnu) 5 | #:use-module (emacsy coroutine) 6 | #:use-module (emacsy agenda) 7 | #:export ( 8 | job? 9 | make-job 10 | get-job-id 11 | suspend-job 12 | continue-job)) 13 | 14 | (define-record-type 15 | (%make-job job-id job-state job-exit-value job-cont) 16 | job? 17 | (job-id job-id) 18 | (job-state job-state set-job-state!) 19 | (job-exit-value job-exit-value set-job-exit-value!) 20 | (job-cont job-cont set-job-cont!)) 21 | 22 | (set-record-type-printer! 23 | (lambda (job port) 24 | (format port "# port))) 34 | 35 | 36 | 37 | (define *current-job-list* '()) 38 | 39 | (define next-job-id 1) 40 | 41 | (define (job-id->job jid) 42 | (find (lambda (job) 43 | (eq? (job-id job) jid)) 44 | *current-job-list*)) 45 | 46 | (define (coerce-to-job job-or-jid) 47 | (if (job? job-or-jid) 48 | job-or-jid 49 | (job-id->job job-or-jid))) 50 | 51 | (define* (make-job thunk) 52 | "Creates a coroutine that has some job control." 53 | (let ((job (%make-job next-job-id 'baby #f #f))) 54 | (define (handler cont key . args) 55 | (define (resume . args) 56 | #;(format #t "resuming job ~a~%" (job-id job)) 57 | ;; Call continuation that resumes the procedure. 58 | (call-with-prompt 'coroutine-prompt 59 | (lambda () (apply cont args)) 60 | handler)) 61 | (define (job-resume . args) 62 | (if (eq? (job-state job) 'running) 63 | (apply resume args) 64 | (begin 65 | (set-job-cont! job job-resume) 66 | #;(format #t "job ~a unable to resume because it is ~a~%" 67 | (job-id job) 68 | (job-state job))))) 69 | (case key 70 | ((callback) 71 | (when (procedure? (car args)) 72 | (apply (car args) job-resume (cdr args)))) 73 | ((user-data) 74 | (resume job)))) 75 | (set! next-job-id (1+ next-job-id)) 76 | (set! *current-job-list* (cons job *current-job-list*)) 77 | (values 78 | (lambda () 79 | (if (eq? (job-state job) 'baby) 80 | (begin 81 | (set-job-state! job 'running) 82 | #;(format #t "starting job ~a~%" (job-id job)) 83 | (call-with-prompt 'coroutine-prompt 84 | (lambda () (job-exit (thunk))) 85 | handler)) 86 | (throw 'job-already-started))) 87 | job))) 88 | 89 | (define (suspend-job job-or-jid) 90 | "Suspend a job that is currently running." 91 | (set-job-state! (coerce-to-job job-or-jid) 'suspended)) 92 | 93 | (define (continue-job job-or-jid) 94 | "Continue a suspended job and schedule it to be run." 95 | (let ((job (coerce-to-job job-or-jid))) 96 | (when (eq? (job-state job) 'suspended) 97 | (set-job-state! job 'running) 98 | (agenda-schedule (job-cont job)) 99 | (set-job-cont! job #f)))) 100 | 101 | (define (wait-for-job job-or-jid) 102 | "Waits for a job to complete." 103 | ;; XXX This should be smarter than polling. 104 | (let ((job (coerce-to-job job-or-jid))) 105 | (while (not (eq? (job-state job) 'zombie)) 106 | (wait)) 107 | (job-exit-value job))) 108 | 109 | (define (job-exit return-value) 110 | "Exit the job with the given return-value." 111 | (let ((job (couser-data))) 112 | (set-job-state! job 'zombie) 113 | (set-job-exit-value! job return-value)) 114 | (yield (lambda (resume) 115 | return-value))) 116 | 117 | (define (get-job-id) 118 | "Returns the job-id within the job." 119 | (job-id (couser-data))) 120 | -------------------------------------------------------------------------------- /src/emacsy/kbd-macro.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | \section{Keyboard Macro Module} 3 | 4 | 5 | \epigraph{...}{...} 6 | 7 | We will now add a keyboard macro facility familiar to Emacs users. We 8 | hook into the [[read-event]] procedure using a hook. 9 | 10 | <>= 11 | ;; XXX This also may record the key event that stops the keyboard 12 | ;; macro, which it shouldn't. 13 | (define (kbd-read-event-hook event) 14 | (when defining-kbd-macro? 15 | (message "RECORDING ~a" event) 16 | (cons! event last-kbd-macro))) 17 | @ 18 | 19 | <>= 20 | ;; How do I ensure this only happens once? 21 | (add-hook! read-event-hook kbd-read-event-hook) 22 | @ 23 | 24 | \subsection{kmacro-start-macro} 25 | 26 | <>= 27 | (define-interactive (kmacro-start-macro) 28 | (set! last-kbd-macro '()) 29 | (set! defining-kbd-macro? #t)) 30 | @ 31 | 32 | <>= 33 | (define-public defining-kbd-macro? #f) 34 | (define-public last-kbd-macro '()) 35 | @ 36 | 37 | \subsection{kmacro-end-macro} 38 | 39 | <>= 40 | (define-interactive (kmacro-end-macro) 41 | (set! defining-kbd-macro? #f)) 42 | @ 43 | 44 | \subsection{kmacro-end-and-call-macro} 45 | <>= 46 | (define-interactive (kmacro-end-and-call-macro) 47 | (if defining-kbd-macro? 48 | (kmacro-end-macro)) 49 | (execute-kbd-macro last-kbd-macro)) 50 | @ 51 | 52 | \subsection{execute-kbd-macro} 53 | 54 | <>= 55 | (define-interactive 56 | (execute-kbd-macro #:optional 57 | (kbd-macro last-kbd-macro) 58 | (count 1) (loopfunc #f)) 59 | (let ((orig-event-queue event-queue) 60 | (new-event-queue (make-q))) 61 | (for-each (lambda (x) 62 | (enq! new-event-queue x)) 63 | (reverse kbd-macro)) 64 | (in-out-guard 65 | (lambda () 66 | (set! event-queue new-event-queue) 67 | (set! executing-kbd-macro? #t)) 68 | (lambda () 69 | (command-loop (lambda args (not (q-empty? event-queue))))) 70 | ;; Turn off the executing-kbd-macro?. 71 | (lambda () 72 | (set! executing-kbd-macro? #f) 73 | (set! event-queue orig-event-queue) 74 | (run-hook kbd-macro-termination-hook))))) 75 | @ 76 | 77 | <>= 78 | (define-public executing-kbd-macro? #f) 79 | (define-public kbd-macro-termination-hook (make-hook)) 80 | @ 81 | 82 | Let's set up a command to test our functionality with. 83 | 84 | <>= 85 | (define test-command-called 0) 86 | (define test-keymap (make-keymap)) 87 | (define-interactive (test-command) 88 | (incr! test-command-called)) 89 | 90 | (define-key test-keymap (kbd "a") 'test-command) 91 | (set! default-klecl-maps (lambda () (list test-keymap))) 92 | 93 | (check test-command-called => 0) 94 | (kmacro-start-macro) 95 | (emacsy-key-event #\a) 96 | (emacsy-key-event #\b) ;; this executes no command. 97 | (primitive-command-loop (lambda args #f)) 98 | (primitive-command-loop (lambda args #f)) 99 | (kmacro-end-macro) 100 | (check test-command-called => 1) 101 | (check (map command-char last-kbd-macro) => '(#\b #\a)) 102 | (execute-kbd-macro last-kbd-macro) 103 | (check test-command-called => 2) 104 | @ 105 | 106 | \subsection{execute-temporal-kbd-macro} 107 | 108 | In addition to regular keyboard macros, Emacsy can execute keyboard 109 | macros such that they reproduce the keys at the same pace as they were 110 | recorded. 111 | 112 | <>= 113 | (define-interactive 114 | (execute-temporal-kbd-macro #:optional (kbd-macro last-kbd-macro)) 115 | (in-out 116 | (set! executing-kbd-macro? #t) 117 | (let* ((start-time (emacsy-time)) 118 | (macro-start-time (time (last kbd-macro)))) 119 | (let loop ((macro (reverse kbd-macro))) 120 | (when (not (null? macro)) 121 | (block-until (lambda () 122 | (let ((duration (- (emacsy-time) start-time) )) 123 | (run-hook executing-temporal-kbd-macro-hook duration) 124 | (>= duration 125 | (- (time (car macro)) macro-start-time))))) 126 | (emacsy-event (car macro)) 127 | (loop (cdr macro))))) 128 | (begin 129 | (set! executing-kbd-macro? #f) 130 | (run-hook kbd-macro-termination-hook)))) 131 | @ 132 | 133 | <>= 134 | (define-public executing-temporal-kbd-macro-hook (make-hook 1)) 135 | @ 136 | 137 | <>= 138 | (check test-command-called => 2) 139 | (execute-temporal-kbd-macro last-kbd-macro) 140 | (primitive-command-loop (lambda args #f)) 141 | (check test-command-called => 3) 142 | @ 143 | 144 | 145 | \subsection*{File Layout} 146 | 147 | <>= 148 | (define-module (emacsy kbd-macro) 149 | #:use-module (ice-9 q) 150 | #:use-module (srfi srfi-1) 151 | #:use-module (emacsy util) 152 | #:use-module (emacsy event) 153 | #:use-module (emacsy command) 154 | #:use-module (emacsy keymap) 155 | #:use-module (emacsy klecl) 156 | #:use-module (emacsy block)) 157 | <> 158 | <> 159 | <> 160 | <> 161 | <> 162 | @ 163 | 164 | Layout for tests. 165 | <>= 166 | (use-modules (emacsy kbd-macro) 167 | (emacsy event) 168 | (emacsy command) 169 | (emacsy klecl) 170 | (oop goops) 171 | (check)) 172 | 173 | (use-private-modules (emacsy kbd-macro)) 174 | 175 | (set! emacsy-interactive? #t) 176 | 177 | <<+ Test Preamble>> 178 | <> 179 | <<+ Test Postscript>> 180 | @ 181 | 182 | -------------------------------------------------------------------------------- /src/emacsy/keymap.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | \section{Keymap Module} 3 | 4 | The keymap stores the mapping between key strokes---or events---and 5 | commands. Emacs uses lists for its representation of keymaps. Emacsy 6 | instead uses a class that stores entries in a hash table. Another 7 | difference for Emacsy is that it does not convert \verb|S-C-a| to a 8 | different representation like \verb|[33554433]|; it leaves it as a 9 | string that is expected to be turned into a canonical representation 10 | ``C-A''. 11 | 12 | Here is an example of the keymap representation in Emacs. 13 | 14 | \begin{verbatim} 15 | > (let ((k (make-sparse-keymap))) 16 | (define-key k "a" 'self-insert-command) 17 | (define-key k "" 'mouse-drag-region) 18 | (define-key k "C-x C-f" 'find-file-at-point) 19 | k) 20 | 21 | (keymap 22 | (24 keymap 23 | (6 . find-file-at-point)) 24 | (mouse-1 . mouse-drag-region) 25 | (97 . self-insert-command)) 26 | \end{verbatim} 27 | 28 | When I initially implemented Emacsy, I replicated Emacs' keymap 29 | representation, but I realized it wasn't necessary. And it seems 30 | preferrable to make the representation more transparent to casual 31 | inspection. Also, Emacsy isn't directly responsible for the 32 | conversion of keyboard events into [[key-event]]s---that's a lower 33 | level detail that the embedding application must handle. Here is the 34 | same keymap as above but in Emacsy. 35 | 36 | \begin{verbatim} 37 | > (let ((k (make-keymap))) 38 | (define-key k "a" 'self-insert-command) 39 | (define-key k "mouse-1" 'mouse-drag-region) 40 | (define-key k "C-x C-f" 'find-file-at-point) 41 | k) 42 | 43 | # 47 | mouse-1 mouse-drag-region> 48 | \end{verbatim} 49 | 50 | There are a few differences in how the keymap is produced, and the 51 | representation looks slightly different too. For one thing it's not a 52 | list. 53 | 54 | \todo[inline]{Justify decisions that deviate from Emacs' design.} 55 | 56 | Our keymap class has a hashtable of entries and possibly a parent 57 | keymap. 58 | 59 | <>= 60 | (define-class-public () 61 | (entries #:getter entries #:init-thunk (lambda () (make-hash-table))) 62 | (parent #:accessor parent #:init-keyword #:parent #:init-value #f)) 63 | @ 64 | 65 | <>= 66 | (check-true (make )) 67 | @ 68 | 69 | The core functionality of the keymap is being able to define and look 70 | up key bindings. 71 | 72 | \subsection{Lookup Key} 73 | 74 | The procedure [[lookup-key]] return a keymap or symbol for a given 75 | list of keys. Consider this test keymap 76 | 77 | <>= 78 | (define (self-insert-command) #f) ;; make a fake command 79 | (define (mouse-drag-region) #f) ;; make a fake command 80 | (define (find-file-at-point) #f) ;; make a fake command 81 | (define k (make-keymap)) 82 | (define-key k "a" 'self-insert-command) 83 | (define-key k "mouse-1" 'mouse-drag-region) 84 | (define-key k "C-x C-f" 'find-file-at-point) 85 | @ 86 | \noindent [[lookup-key]] should behave in the following way. 87 | 88 | <>= 89 | (define (lookup-key* . args) 90 | (let ((result (apply lookup-key args))) 91 | (if (procedure? result) 92 | (procedure-name result) 93 | result))) 94 | (check (lookup-key* k '("a")) => 'self-insert-command-trampoline) 95 | (check (lookup-key* k "a") => 'self-insert-command-trampoline) 96 | (check (lookup-key k '("b")) => #f) 97 | (check (lookup-key k "M-x b") => #f) 98 | (check-true (keymap? (lookup-key k '("C-x")))) 99 | (check (lookup-key k "C-x C-f a b" #f) => 2) 100 | @ 101 | 102 | <>= 103 | (define*-public (lookup-key keymap keys #:optional (follow-parent? #t)) 104 | (define* (lookup-key* keymap keys #:optional (follow-parent? #t)) 105 | (if (null? keys) 106 | keymap 107 | (let ((entry (hash-ref (entries keymap) (car keys)))) 108 | (if entry 109 | (if (keymap? entry) 110 | ;; Recurse into the next keymap. 111 | (1+if-number (lookup-key* entry (cdr keys) follow-parent?)) 112 | ;; Entry exists. 113 | (if (null? (cdr keys)) 114 | ;; Specifies the right number of keys; return 115 | ;; entry. 116 | entry 117 | ;; Entry exists but there are more keys; return a 118 | ;; number. 119 | 1)) 120 | ;; No entry; try the parent. 121 | (if (and follow-parent? (parent keymap)) 122 | (lookup-key* (parent keymap) keys follow-parent?) 123 | ;; No entry; no parent. 124 | #f))))) 125 | (lookup-key* keymap (if (string? keys) 126 | (kbd keys) 127 | keys) follow-parent?)) 128 | @ 129 | 130 | We propagate the error using a number using the following procedure. 131 | 132 | <>= 133 | (define (1+if-number x) 134 | (if (number? x) 135 | (1+ x) 136 | x)) 137 | @ 138 | 139 | Because delivering the errors using booleans and numbers is a little 140 | cumbersome (and perhaps should be replaced with exceptions?), 141 | sometimes we just want to see if there is something in the keymap. 142 | 143 | <>= 144 | (check (lookup-key? k "C-x") => #f) 145 | (check (lookup-key? k "C-x C-f") => #t) 146 | (check (lookup-key? k "a") => #t) 147 | @ 148 | 149 | <>= 150 | (define*-public (lookup-key? keymap keyspec #:optional (keymap-ok? #f)) 151 | (let* ((keys (if (string? keyspec) 152 | (kbd keyspec) 153 | keyspec)) 154 | (result (lookup-key keymap keys))) 155 | (if keymap-ok? 156 | (and (not (boolean? result)) 157 | (not (number? result))) 158 | (and (not (keymap? result)) 159 | (not (boolean? result)) 160 | (not (number? result)))))) 161 | @ 162 | 163 | \subsection{Define Key} 164 | 165 | The procedure [[define-key]] may return a number indicating an error, 166 | or a keymap indicating it worked. 167 | 168 | <>= 169 | ;(check (define-key k (kbd "C-x C-f C-a C-b") 'nope) => 2) 170 | @ 171 | 172 | <>= 173 | (define (make-trampoline module name) 174 | "Creates a trampoline out of a symbol in a given module, e.g. (lambda () (name))" 175 | (let ((var (module-variable module name))) 176 | (unless var 177 | (scm-error 'no-such-variable "make-trampoline" "Can't make a trampoline for variable named '~a that does not exist in module ~a." (list name module) #f)) 178 | (let ((proc (lambda () ((variable-ref var))))) 179 | (set-procedure-property! proc 'name 180 | (string->symbol (format #f "~a-trampoline" name))) 181 | proc))) 182 | @ 183 | 184 | <>= 185 | (define-public (define-key keymap key-list-or-string symbol-or-procedure-or-keymap) 186 | (let* ((keys (if (string? key-list-or-string) 187 | (kbd key-list-or-string) 188 | key-list-or-string)) 189 | (entry (lookup-key keymap (list (car keys)) #f)) 190 | (procedure-or-keymap 191 | (if (symbol? symbol-or-procedure-or-keymap) 192 | (make-trampoline (current-module) symbol-or-procedure-or-keymap) 193 | symbol-or-procedure-or-keymap))) 194 | (cond 195 | ;; Error 196 | ((number? entry) 197 | (error "Terminal key binding already found for ~a keys." entry)) 198 | ;; Keymap available for the first key; recurse! 199 | ((keymap? entry) 200 | (define-key entry (cdr keys) procedure-or-keymap)) 201 | (else 202 | (if (= 1 (length keys)) 203 | ;; This is our last key, just add it to our keymap. 204 | (begin 205 | (hash-set! (entries keymap) (car keys) procedure-or-keymap) 206 | keymap) 207 | ;; We've got a lot of keys left that need to be hung on some 208 | ;; keymap. 209 | (define-key keymap (rcdr keys) 210 | (define-key (make-keymap) (list (rcar keys)) procedure-or-keymap))))))) 211 | @ 212 | 213 | I use some procedures to access the last item of a list, which I call 214 | the [[rcar]], and the tail of the list with respect to its end instead 215 | of its head [[rcdr]]. These aren't efficient and should be replaced 216 | later. 217 | 218 | <>= 219 | (define-public (rcar lst) 220 | (car (reverse lst))) 221 | 222 | (define-public (rcdr lst) 223 | (reverse (cdr (reverse lst)))) 224 | @ 225 | 226 | Let's define a keymap predicate, which is defined in Emacs as 227 | [[keymapp]] ('p' for predicate). I am adopting Scheme's question mark 228 | for predicates which seems more natural. 229 | 230 | <>= 231 | (define-public (keymap? obj) 232 | (is-a? obj )) 233 | @ 234 | 235 | <>= 236 | (check-true (keymap? (make ))) 237 | (check-false (keymap? 1)) 238 | @ 239 | 240 | <>= 241 | (define*-public (make-keymap #:optional (parent #f)) 242 | (make #:parent parent)) 243 | @ 244 | 245 | 246 | <>= 247 | (define-method (write (obj ) port) 248 | (write-keymap obj port)) 249 | 250 | (define* (write-keymap obj port #:optional (keymap-print-prefix 0)) 251 | (display "# i keymap-print-prefix)) 255 | (display " " port)) 256 | (display "\n" port) 257 | (display key port) 258 | (display " " port) 259 | (if (keymap? value) 260 | (write-keymap value port (+ 2 keymap-print-prefix)) 261 | (display value port))) 262 | (entries obj)) 263 | (if (parent obj) 264 | (write-keymap (parent obj) port (+ 2 keymap-print-prefix))) 265 | (display ">" port)) 266 | @ 267 | 268 | <>= 269 | (define-public (lookup-key-entry? result) 270 | (and (not (boolean? result)) (not (number? result)))) 271 | @ 272 | 273 | \subsection*{File Layout} 274 | 275 | <>= 276 | (define-module (emacsy keymap) 277 | #:use-module (ice-9 regex) 278 | #:use-module (ice-9 optargs) 279 | #:use-module (oop goops) 280 | #:use-module (emacsy util) 281 | #:use-module (emacsy event)) 282 | <> 283 | <> 284 | <> 285 | <> 286 | <> 287 | @ 288 | 289 | Layout for tests. 290 | <>= 291 | (use-modules (emacsy keymap) 292 | (emacsy event) 293 | (oop goops)) 294 | 295 | (eval-when (compile load eval) 296 | ;; Some trickery so we can test private procedures. 297 | (module-use! (current-module) (resolve-module '(emacsy keymap)))) 298 | 299 | <<+ Test Preamble>> 300 | <> 301 | <<+ Test Postscript>> 302 | @ 303 | -------------------------------------------------------------------------------- /src/emacsy/mode.nw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/src/emacsy/mode.nw -------------------------------------------------------------------------------- /src/emacsy/mode.scm: -------------------------------------------------------------------------------- 1 | (define-module (emacsy mode) 2 | #:use-module (ice-9 optargs) 3 | #:use-module (srfi srfi-26) 4 | #:use-module (string completion) 5 | #:use-module (oop goops) 6 | #:use-module (emacsy util) 7 | #:use-module (emacsy self-doc) 8 | #:use-module (emacsy event) 9 | #:use-module (emacsy keymap) 10 | #:use-module (emacsy command) 11 | #:use-module (emacsy klecl) 12 | #:use-module (rnrs base) 13 | #:export ( 14 | mode-name 15 | mode-map)) 16 | 17 | (define-class () 18 | (name #:getter mode-name #:init-keyword #:mode-name) 19 | (mode-map #:accessor mode-map 20 | #:init-keyword #:mode-map 21 | #:init-form (make-keymap))) 22 | -------------------------------------------------------------------------------- /src/emacsy/mru-stack.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | \subsubsection{Most Recently Used Stack} 3 | The buffers are kept in a most recently used stack that has the 4 | following operators: add!, remove!, contains?, recall!, and list. 5 | 6 | <>= 7 | (define-module (emacsy mru-stack) 8 | #:use-module (ice-9 q) 9 | #:use-module (oop goops) 10 | #:use-module (emacsy util) 11 | #:export ( 12 | mru-add! 13 | mru-remove! 14 | mru-recall! 15 | mru-set! 16 | mru-ref 17 | mru-empty? 18 | mru-contains? 19 | mru-next! 20 | mru-prev! 21 | mru-list)) 22 | 23 | <> 24 | <> 25 | @ 26 | 27 | <>= 28 | (define-class () 29 | (queue #:accessor q #:init-thunk (lambda () (make-q))) 30 | (index #:accessor index #:init-value 0)) 31 | @ 32 | 33 | <>= 34 | (define-method (write (obj ) port) 35 | ; (write (string-concatenate (list "#")) port) 36 | (format port "" (mru-list obj))) 37 | @ 38 | 39 | 40 | <>= 41 | (define-method (mru-add! (s ) x) 42 | (q-push! (q s) x)) 43 | (define-method (mru-remove! (s ) x) 44 | (let ((orig-x (mru-ref s))) 45 | (q-remove! (q s) x) 46 | (if (not (eq? orig-x x)) 47 | (mru-set! s orig-x)))) 48 | (define-method (mru-recall! (s ) x) 49 | (q-remove! (q s) x) 50 | (q-push! (q s) x) 51 | (set! (index s) 0) 52 | (mru-list s)) 53 | (define-method (mru-set! (s ) x) 54 | ;; Should this add the buffer if it's not already there? No. 55 | (if (mru-empty? s) 56 | #f 57 | (let ((i (member-ref x (mru-list s)))) 58 | (if i 59 | (begin (set! (index s) i) 60 | #t) 61 | (begin (mru-next! s) 62 | #f))))) 63 | (define-method (mru-ref (s )) 64 | (and (not (mru-empty? s)) 65 | (list-ref (mru-list s) (index s)))) 66 | (define-method (mru-list (s )) 67 | (car (q s))) 68 | (define-method (mru-empty? (s )) 69 | (q-empty? (q s))) 70 | (define-method (mru-contains? (s ) x) 71 | (memq x (mru-list s))) 72 | @ 73 | 74 | The order of the elements may not change yet the index may be moved 75 | around. 76 | 77 | <>= 78 | (define-method (mru-next! (s ) count) 79 | (when (not (mru-empty? s)) 80 | (set! (index s) 81 | (modulo (+ (index s) count) 82 | (length (mru-list s)))) 83 | (mru-ref s))) 84 | (define-method (mru-prev! (s ) count) 85 | (mru-next! s (- count))) 86 | (define-method (mru-prev! (s )) 87 | (mru-prev! s 1)) 88 | (define-method (mru-next! (s )) 89 | (mru-next! s 1)) 90 | @ 91 | 92 | <>= 93 | (use-modules (emacsy mru-stack) 94 | (check)) 95 | 96 | (use-private-modules (emacsy mru-stack)) 97 | <> 98 | (check-exit) 99 | @ 100 | 101 | <>= 102 | (define s (make )) 103 | (mru-add! s 'a) 104 | (mru-add! s 'b) 105 | (mru-add! s 'c) 106 | (check (mru-list s) => '(c b a)) 107 | (check (mru-recall! s 'a) => '(a c b)) 108 | (check (mru-ref s) => 'a) 109 | (mru-next! s) 110 | (check (mru-ref s) => 'c) 111 | (mru-next! s) 112 | (check (mru-ref s) => 'b) 113 | (mru-next! s) 114 | (check (mru-ref s) => 'a) 115 | (mru-prev! s) 116 | (check (mru-ref s) => 'b) 117 | (check (mru-list s) => '(a c b)) 118 | (mru-remove! s 'c) 119 | (check (mru-list s) => '(a b)) 120 | (check (mru-ref s) => 'b) 121 | (mru-remove! s 'a) 122 | (mru-remove! s 'b) 123 | (check (mru-list s) => '()) 124 | (check (mru-ref s) => #f) 125 | (mru-next! s) 126 | (check (mru-ref s) => #f) 127 | (mru-add! s 'a) 128 | (mru-add! s 'b) 129 | (mru-add! s 'c) 130 | (check (mru-list s) => '(c b a)) 131 | (mru-remove! s 'c) 132 | (check (mru-list s) => '(b a)) 133 | (check (mru-ref s) => 'b) 134 | @ 135 | -------------------------------------------------------------------------------- /src/emacsy/self-doc.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 3 | \section{Self Documentation} 4 | 5 | Emacs offers a fantastic comprehensive help system. Emacsy intends to 6 | replicate most of this functionality. One distinction that would be 7 | nice to make is to partition Scheme values into procedures, variables, 8 | and parameters. In Scheme, all these kinds of values are the handled 9 | the same way. In Emacs, each are accessible by the help system 10 | distinctly. For instance, [[C-h f]] looks up functions, [[C-h v]] 11 | looks up variables. In addition to defining what kind of value a 12 | variable holds, this also allows one to include documentation for 13 | values which is not included in Guile Scheme by default. (XXX fact 14 | check.) 15 | 16 | \subsection{define-variable} 17 | 18 | <>= 19 | (define (object-documentation-ref object) 20 | "Return the docstring for OBJECT. 21 | OBJECT can be a procedure, macro or any object that has its 22 | `documentation' property set." 23 | (object-property object 'documentation)) 24 | 25 | (define (object-documentation-set! object value) 26 | "Return the docstring for OBJECT. 27 | OBJECT can be a procedure, macro or any object that has its 28 | `documentation' property set." 29 | (set-object-property! object 'documentation value)) 30 | @ 31 | 32 | <>= 33 | (define (emacsy-kind-ref object) 34 | "Return the kind for the OBJECT." 35 | (object-property object 'emacsy-kind)) 36 | 37 | (define (emacsy-kind-set! object kind) 38 | "Return the kind for the OBJECT." 39 | (set-object-property! object 'emacsy-kind kind)) 40 | @ 41 | 42 | 43 | <>= 44 | (define-syntax-public define-variable 45 | (syntax-rules () 46 | ((define-variable name value documentation) 47 | (begin 48 | (define-once name value) 49 | ;(define-documentation name documentation) 50 | (let ((v (module-variable (current-module) 'name))) 51 | (emacsy-kind-set! v 'variable) 52 | (object-documentation-set! v documentation) 53 | (set-object-property! v 'source-properties (current-source-location))))) 54 | 55 | ((define-variable name value) 56 | (define-variable name value "")))) 57 | @ 58 | 59 | <>= 60 | (define-syntax-public define-documentation 61 | (syntax-rules () 62 | ((define-documentation name documentation) 63 | (begin 64 | (let ((v (module-variable (current-module) 'name))) 65 | (object-documentation-set! v documentation) 66 | (set-object-property! v 'source-properties (current-source-location))))))) 67 | @ 68 | 69 | XXX Rename from variable-documentation to just documentation. 70 | 71 | <>= 72 | (define-public (variable-documentation variable-or-symbol) 73 | (let ((v (cond 74 | ((symbol? variable-or-symbol) 75 | ;(format #t "IN current-module ~a~%" (current-module)) 76 | (module-variable (current-module) variable-or-symbol)) 77 | ((variable? variable-or-symbol) 78 | (object-documentation-ref variable-or-symbol)) 79 | (else 80 | (scm-error 81 | 'no-such-variable 82 | "variable-documentation" 83 | "Expected a symbol in the current module or a variable; got ~a" 84 | (list variable-or-symbol) 85 | #f))))) 86 | (if v 87 | (object-documentation-ref v) 88 | #f))) 89 | @ 90 | 91 | <>= 92 | (define-variable x 1 "This is the variable x.") 93 | (check x => 1) 94 | ;(format #t "OUT current-module ~a~%" (current-module)) 95 | (check (variable-documentation (module-variable (current-module) 'x)) => "This is the variable x.") 96 | (check (variable-documentation 'x) => "This is the variable x.") 97 | (define-variable x 2 "This is the variable x.") 98 | (check x => 1) 99 | (check (variable-documentation 'x) => "This is the variable x.") 100 | (set! x 3) 101 | (check x => 3) 102 | (check (variable-documentation 'x) => "This is the variable x.") 103 | 104 | ;; When we re-define x, the documentation stays. 105 | (define x 4) 106 | (check (variable-documentation 'x) => "This is the variable x.") 107 | (check x => 4) 108 | (define-variable x 5 "This is the variable x; it is!") 109 | (check x => 4) 110 | (check (variable-documentation 'x) => "This is the variable x; it is!") 111 | 112 | (define-variable x 5 "This is the variable x.") 113 | @ 114 | 115 | We also want to be able to collect up all the variables in some given 116 | module. 117 | 118 | <>= 119 | (define* (emacsy-collect-kind module kind #:optional (depth 0)) 120 | "Return the symbols that are of the variable, parameter, or 121 | command kind. Inspects symbols defined locally within the module and 122 | of the interfaces it includes (up to a given depth)." 123 | (let ((results '())) 124 | (define (collect module) 125 | (module-for-each 126 | (lambda (symbol variable) 127 | (if (eq? kind (emacsy-kind-ref variable)) 128 | (cons! symbol results))) 129 | module)) 130 | (define expander 131 | (match-lambda 132 | ((mod current-depth) 133 | (map (lambda (child-mod) 134 | (list child-mod (1+ current-depth))) 135 | (module-uses mod))))) 136 | (define done? 137 | (match-lambda 138 | ((mod current-depth) 139 | (if (<= current-depth depth) 140 | (collect mod)) 141 | (> current-depth depth)))) 142 | (breadth-first-search (list module 0) done? expander) 143 | results)) 144 | @ 145 | 146 | <>= 147 | (check (emacsy-collect-kind (current-module) 'variable) => '(x)) 148 | @ 149 | 150 | \subsection{define-parameter} 151 | 152 | Parameters behave similarly to variables; however, whenever they are 153 | defined, their values are set. 154 | 155 | <>= 156 | (define-syntax-public define-parameter 157 | (syntax-rules () 158 | ((define-parameter name value documentation) 159 | (begin 160 | (define name value) 161 | (let ((v (module-variable (current-module) 'name))) 162 | (when v 163 | (emacsy-kind-set! v 'parameter) 164 | (object-documentation-set! v documentation) 165 | (set-object-property! v 'source-properties (current-source-location)))))) 166 | ((define-parameter name value) 167 | (define-parameter name value "")))) 168 | @ 169 | 170 | <>= 171 | (define-parameter y 1 "This is the parameter y.") 172 | (check y => 1) 173 | (check (variable-documentation 'y) => "This is the parameter y.") 174 | (define-parameter y 2 "This is the parameter y.") 175 | (check y => 2) 176 | (check (variable-documentation 'y) => "This is the parameter y.") 177 | (set! y 3) 178 | (check y => 3) 179 | (check (variable-documentation 'y) => "This is the parameter y.") 180 | ;(check (object-properties (module-variable (current-module) 'y)) => '()) 181 | (check (emacsy-collect-kind (current-module) 'parameter) => '(y)) 182 | (define emacsy-collect-all-kind emacsy-collect-kind) 183 | (check (emacsy-collect-all-kind (current-module) 'parameter 0) => '(y)) 184 | @ 185 | 186 | Now let's try to start a new module. And probe some of the behavior. 187 | 188 | <>= 189 | (define-module (test-this) 190 | #:use-module (check) 191 | #:use-module (emacsy self-doc)) 192 | 193 | 194 | (check (emacsy-collect-kind (current-module) 'parameter) => '()) 195 | (check (emacsy-collect-kind (current-module) 'variable) => '()) 196 | (check (module-name (current-module)) => '(test-this)) 197 | 198 | ;; XXX These two tests behave differently on GNU/Linux and Mac OS X. 199 | ;(check (module-variable (current-module) 'x) => #f) 200 | ;(check (variable-documentation 'x) => #f) 201 | ;(check (variable-documentation 'y) => #f) 202 | 203 | (use-private-modules (guile-user)) 204 | 205 | (check x => 4) 206 | (check y => 3) 207 | (check (variable-documentation 'x) => "This is the variable x.") 208 | (check (variable-documentation (module-variable (current-module) 'x)) => "This is the variable x.") 209 | (check (variable-documentation 'y) => "This is the parameter y.") 210 | (check (variable-documentation (module-variable (current-module) 'y)) => "This is the parameter y.") 211 | (check (emacsy-collect-kind (current-module) 'variable) => '()) 212 | (check (emacsy-collect-kind (current-module) 'parameter) => '()) 213 | 214 | (check (emacsy-collect-all-kind (current-module) 'variable) => '()) 215 | (check (emacsy-collect-all-kind (current-module) 'parameter) => '()) 216 | 217 | (check (emacsy-collect-all-kind (current-module) 'variable 1) => '(x)) 218 | (check (emacsy-collect-all-kind (current-module) 'parameter 1) => '(y)) 219 | 220 | (check (string-suffix? "emacsy/self-doc-test.scm" (assoc-ref (current-source-location) 'filename)) => #t) 221 | (check (current-filename) => #f) 222 | (check (source-properties x) => '()) 223 | (check (source-properties 'x) => '()) 224 | (check (source-properties (module-variable (current-module) 'x)) => '()) 225 | @ 226 | 227 | 228 | 229 | \subsection{File Layout} 230 | 231 | <>= 232 | (define-module (emacsy self-doc) 233 | #:use-module (emacsy util) 234 | #:use-module (srfi srfi-1) 235 | #:use-module (search basic) 236 | #:use-module (ice-9 optargs) 237 | #:use-module (ice-9 match) 238 | #:use-module (ice-9 documentation) 239 | #:export (emacsy-collect-kind 240 | emacsy-kind-ref 241 | emacsy-kind-set! 242 | )) 243 | 244 | <> 245 | <> 246 | @ 247 | 248 | <>= 249 | (use-modules (check) 250 | (emacsy self-doc)) 251 | (use-private-modules (emacsy self-doc)) 252 | 253 | <> 254 | 255 | <> 256 | 257 | (check-exit) 258 | @ 259 | -------------------------------------------------------------------------------- /src/emacsy/util.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | \section{Utility Module} 3 | 4 | The [[util]] module is a grab bag of all sorts of miscellaneous 5 | functionality. Rather than defining it here in one place. I thought 6 | it'd be best to define each piece where it is actually introduced and 7 | used. 8 | 9 | <>= 10 | (define-syntax define-syntax-public 11 | (syntax-rules () 12 | ((define-syntax-public name . body) 13 | (begin 14 | (define-syntax name . body) 15 | (export-syntax name))))) 16 | (export-syntax define-syntax-public) 17 | @ 18 | 19 | <>= 20 | (define-syntax-public string-case 21 | (syntax-rules (else) 22 | ((_ str (else e1 ...)) 23 | (begin e1 ...)) 24 | ((_ str (e1 e2 ...)) 25 | (when (string=? str e1) e2 ...)) 26 | ((_ str (e1 e2 ...) c1 ...) 27 | (if (string=? str e1) 28 | (begin e2 ...) 29 | (string-case str c1 ...))))) 30 | @ 31 | 32 | <>= 33 | (define-syntax-public define-class-public 34 | (syntax-rules () 35 | ((define-class-public name . body) 36 | (begin 37 | (define-class name . body) 38 | (export name) 39 | )))) 40 | @ 41 | 42 | <>= 43 | (define-syntax-public define-method-public 44 | (syntax-rules () 45 | ((define-method-public (name . args) . body) 46 | (begin 47 | (define-method (name . args) . body) 48 | (export name) 49 | )))) 50 | @ 51 | 52 | <>= 53 | (define-syntax define-generic-public 54 | (syntax-rules () 55 | ((define-generic-public name) 56 | (begin 57 | (define-generic name) 58 | (export name))))) 59 | (export define-generic-public) 60 | @ 61 | 62 | <>= 63 | (define-public pp pretty-print) 64 | @ 65 | 66 | <>= 67 | (define-module (emacsy util) 68 | #:use-module (ice-9 optargs) 69 | #:use-module (oop goops) 70 | #:use-module (ice-9 pretty-print) 71 | #:use-module (ice-9 receive) 72 | #:use-module (srfi srfi-1) 73 | #:use-module (debugging assert) 74 | #:use-module (system repl error-handling) 75 | ;#:export-syntax (define-syntax-public) 76 | ) 77 | <> 78 | <> 79 | <> 80 | @ 81 | 82 | <>= 83 | (define-public (repeat-func count func) 84 | (if (<= count 0) 85 | #f 86 | (begin 87 | (func) 88 | (repeat-func (1- count) func)))) 89 | @ 90 | <>= 91 | (define-syntax-public repeat 92 | (syntax-rules () 93 | ((repeat c e ...) 94 | (repeat-func c (lambda () e ...))))) 95 | @ 96 | -------------------------------------------------------------------------------- /src/emacsy/window.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: scheme-mode -*- 2 | \section{Windows (Optional)} 3 | 4 | Emacsy aims to offer the minimal amount of intrusion to acquire big 5 | gains in program functionality. Windows is an optional module for 6 | Emacsy. If you want to offer windows that behave like Emacs windows, 7 | you can, but you aren't required to. 8 | 9 | <>= 10 | <<+ Lisp File Header>> 11 | <> 12 | <> 13 | <> 14 | <> 15 | <> 16 | <> 17 | @ 18 | <>= 19 | (define-module (emacsy window) 20 | #:use-module (oop goops) 21 | #:use-module (emacsy emacsy) 22 | <> 23 | #:export ( 24 | 25 | window? 26 | split-window 27 | window-buffer 28 | window-children 29 | orientation 30 | user-data 31 | window-list 32 | root-window 33 | current-window 34 | window-configuration-change-hook 35 | window-clone) 36 | #:export-syntax ( <> ) 37 | ) 38 | @ \section{Classes} 39 | 40 | The window class contains a renderable window that is associated with 41 | a buffer. 42 | 43 | <>= 44 | (define-class () 45 | (window-parent #:accessor window-parent #:init-value #f) 46 | (user-data #:accessor user-data #:init-keyword #:user-data #:init-value #f) 47 | (window-buffer #:accessor window-buffer #:init-keyword #:window-buffer #:init-value #f) 48 | (window-dedicated? #:accessor window-dedicated? #:init-value #f)) 49 | @ %def 50 | @ The internal window class contains other windows. 51 | 52 | <>= 53 | (define-class () 54 | (window-parent #:accessor window-parent #:init-value #f) 55 | (user-data #:accessor user-data #:init-keyword #:user-data #:init-value #f) 56 | (window-children #:accessor window-children #:init-keyword #:window-children #:init-value '()) 57 | (orientation #:accessor orientation #:init-keyword #:orientation #:init-value 'vertical) ; or 'horizontal 58 | (size #:accessor size #:init-keyword #:size #:init-value .5)) 59 | @ %def 60 | \section{Procedures} 61 | 62 | <>= 63 | (define-method (initialize (obj ) initargs) 64 | (next-method) 65 | (for-each (lambda (window) 66 | (set! (window-parent window) obj)) (window-children obj))) 67 | 68 | (define (window? o) 69 | (or (is-a? o ) (is-a? o ))) 70 | @ 71 | 72 | <>= 73 | (check (window? root-window) => #t) 74 | @ 75 | <>= 76 | (define (window-live? o) 77 | (is-a? o )) 78 | @ 79 | <>= 80 | (check (window-live? root-window) => #t) 81 | @ 82 | <>= 83 | (define (frame-root-window) 84 | root-window) 85 | <>= 86 | (define-public root-window (make )) 87 | <>= 88 | #:use-module (ice-9 match) 89 | @ Emacs uses the edges of windows \verb|(left top right bottom)|, but 90 | I'm more comfortable using bounded coordinate systems 91 | \verb|(left bottom width height)|. So let's write some converters. 92 | 93 | <>= 94 | (define (edges->bcoords edges) 95 | (match edges 96 | ((left top right bottom) 97 | (list left bottom (- right left) (- top bottom))))) 98 | @ 99 | <>= 100 | (check (edges->bcoords '(0 1 1 0)) => '(0 0 1 1)) 101 | @ 102 | <>= 103 | (define (bcoords->edges coords) 104 | (match coords 105 | ((x y w h) 106 | (list x (+ y h) (+ x w) y)))) 107 | @ 108 | <>= 109 | (check (bcoords->edges '(0 0 1 1)) => '(0 1 1 0)) 110 | @ The best way I can think to tile and scale all these windows is like 111 | this. Let's use a normalized bounded coordinates for the internal 112 | windows. This way the frame size can change and the pixel edges can 113 | be recomputed. 114 | 115 | \begin{figure} 116 | \centering 117 | % \includegraphics[scale=0.75]{window-diagram.pdf} 118 | \caption[Window Diagram]{\label{window-diagram}Window $A$ can be 119 | fully described by two vectors: its origin $\bv o_a = (ox, oy)$ 120 | and its end $\bv e_a = (w_a, h_a)$.} 121 | \end{figure} 122 | 123 | 124 | Imagine the frame has a width $W$ and a height H. My root window has 125 | the bounded coordinates \verb|(0 0 1 1)|. When I call 126 | \verb|window-pixel-coords| on it, it will return \verb|(0 0 W H)|. 127 | 128 | Consider the case where my root window is split vertically in half. 129 | My root window would be an internal window with the same bounded 130 | coordinates as before. The top child, however, will have its pixel 131 | bounded coordinates as \verb|(0 (/ H 2) W (/ H 2)|. And the bottom 132 | child will have \verb|(0 0 W (/ H 2))|. 133 | 134 | One way to think of this is every \verb|| takes up all its 135 | space; intrinsically, they are all set to \verb|(0 0 1 1)|. The trick 136 | is each \verb|| divides up the space recursively. So 137 | the internal window in the preceding example that was split 138 | vertically, it passes \verb|0 .5 1 .5| to the top child and 139 | \verb|0 0 1 .5|. 140 | 141 | When the root window, or frame in Emacs parlance, is resized, we want 142 | each windows by default to resize proportionately. The windows will 143 | be tiled; therefore, it seems appropriate to use the unit of 144 | proportions as our representation over pixels. There will be some 145 | windows that will have a size of a particular pixel size, like the 146 | minibuffer window. A little bit of specialization to maintain a 147 | particular pixel height will require some callbacks or hooks. 148 | 149 | \subsection{Overriding switch-to-buffer} 150 | 151 | When the user switches to a buffer, then the current window should be 152 | switched to that window. It'd be preferrable to use an advice 153 | mechanism, but I haven't finished writing that module yet, so we'll 154 | have to settle for something a little more clunky. 155 | 156 | <>= 157 | (let ((old-func switch-to-buffer)) 158 | (set! switch-to-buffer 159 | (lambda-cmd args 160 | (let ((result (apply old-func args))) 161 | (format #t "Setting current window to buffer ~a~%" (current-buffer)) 162 | (set! (window-buffer current-window) (current-buffer)) 163 | result)))) 164 | @ 165 | 166 | \subsection{Split Window} 167 | 168 | Be careful with \verb|deep-clone|. If you deep clone one window that 169 | has references to other windows, you will clone entire object graph. 170 | 171 | <>= 172 | (define-interactive (split-window #:optional 173 | (window (selected-window)) 174 | (size 0.5) 175 | (side 'below)) 176 | (define (substitute x y) 177 | "Returns a function that will substitute x for y when given x." 178 | (lambda (z) 179 | (if (eq? z x) 180 | y 181 | z))) 182 | (let* ((original-parent (window-parent window)) 183 | (new-child (window-clone window)) 184 | (internal-window (make 185 | #:window-children (list window new-child) 186 | #:size size 187 | #:orientation (if (memq side '(below above)) 188 | 'vertical 189 | 'horizontal)))) 190 | (set! (window-parent internal-window) original-parent) 191 | (set! (window-parent window) internal-window) 192 | (set! (window-parent new-child) internal-window) 193 | (when original-parent 194 | (set! (window-children original-parent) 195 | (map (substitute window internal-window) 196 | (window-children original-parent)))) 197 | (run-hook window-configuration-change-hook original-parent) 198 | (update-window internal-window) 199 | internal-window)) 200 | @ %def split-window 201 | 202 | <>= 203 | (define-method (window-clone (window )) 204 | (shallow-clone window)) 205 | @ 206 | <>= 207 | (define-variable window-configuration-change-hook (make-hook 1) "This hook is called when a window is split.") 208 | <>= 209 | (define-public (selected-window) 210 | current-window) 211 | @ 212 | <>= 213 | (define current-window #f) 214 | @ If the internal window size is changed, we want to update the sizes of 215 | its children. 216 | 217 | <>= 218 | (define-method (update-window (window )) 219 | #f 220 | #;(let ((children (window-children window))) 221 | (if (eq? (orientation window) 'vertical) 222 | <> 223 | <>))) 224 | @ 225 | 226 | Let's project a point in the current window to the point in its 227 | ultimate parent window. 228 | 229 | <>= 230 | (define i-window (make )) 231 | (define window (make )) 232 | (check (window? i-window) => #t) 233 | (check (window? window) => #t) 234 | @ Let's test window splitting. 235 | 236 | <>= 237 | (check (procedure? split-window) => #t) 238 | (define s-window (split-window window)) 239 | (check (is-a? s-window ) => #t) 240 | @ Let's test window splitting with a different size value. 241 | <>= 242 | (define small-window (make )) 243 | (define parent-window (split-window small-window 0.2)) 244 | (define big-window (cdr (window-children parent-window))) 245 | (check (orientation parent-window) => 'vertical) 246 | @ Let's test window splitting with a different orientation. 247 | 248 | <>= 249 | (define left-window (make )) 250 | (define parent-window-2 (split-window left-window 0.2 'right)) 251 | (define right-window (cdr (window-children parent-window-2))) 252 | (check (orientation parent-window-2) => 'horizontal) 253 | @ 254 | 255 | \subsection{Window List} 256 | 257 | <>= 258 | (define-method (window-tree (w )) 259 | (map window-tree (window-children w))) 260 | 261 | (define-method (window-tree (w )) 262 | w) 263 | 264 | <>= 265 | (define (flatten x) 266 | (cond ((null? x) '()) 267 | ((not (pair? x)) (list x)) 268 | (else (append (flatten (car x)) 269 | (flatten (cdr x)))))) 270 | 271 | (define* (window-list #:optional (w root-window)) 272 | (flatten (window-tree w))) 273 | <>= 274 | (let* ((w (make )) 275 | (sw (split-window w)) 276 | (c (cadr (window-children sw))) 277 | (sc (split-window c)) 278 | (nc (cadr (window-children sc))) 279 | ) 280 | 281 | (check (window-list w) => (list w)) 282 | (check (window-tree sw) => (list w (list c nc))) 283 | (check (window-list sw) => (list w c nc)) 284 | ;(check (window-list sw) => (list w c #f)) 285 | ) 286 | @ \section{Window Commands} 287 | 288 | <>= 289 | (define-interactive (split-window-below #:optional (size .5)) 290 | (split-window (selected-window) size 'below)) 291 | @ 292 | 293 | <>= 294 | (define-interactive (split-window-right #:optional (size .5)) 295 | (split-window (selected-window) size 'right)) 296 | @ 297 | 298 | <>= 299 | (define-interactive (delete-window #:optional (window (selected-window))) 300 | (let ((p (window-parent window))) 301 | ;; Only delete if it has a parent. 302 | (when p 303 | (let* ((children (window-children p)) 304 | (new-children (delq window children))) 305 | (set! (window-children p) new-children) 306 | (set! current-window (car new-children)) 307 | (run-hook window-configuration-change-hook p) 308 | ;; XXX We will want to divest ourselves of any internal-windows 309 | ;; that only contain one child. Not sure if we want to do that here 310 | ;; or in another method though. 311 | #;(if (= 1 (length new-children)) 312 | (car new-children) 313 | (begin 314 | 315 | #t)))))) 316 | 317 | (define-interactive (delete-other-windows #:optional (window (selected-window))) 318 | (set! root-window (make #:window-children (list window))) 319 | (set! current-window window) 320 | (run-hook window-configuration-change-hook root-window)) 321 | 322 | (define-interactive (other-window #:optional (count 1)) 323 | (let* ((lst (window-list root-window)) 324 | (index (member-ref current-window lst))) 325 | (set! current-window (list-ref lst (modulo (+ index count) (length lst)))))) 326 | @ 327 | 328 | \section{Window Key Bindings} 329 | 330 | It will come as no surprise that these key bindings will mimic the 331 | behavior of Emacs. 332 | 333 | <>= 334 | (define-key global-map "C-x 0" 'delete-window) 335 | (define-key global-map "C-x 1" 'delete-other-windows) 336 | (define-key global-map "C-x 2" 'split-window-below) 337 | (define-key global-map "C-x 3" 'split-window-right) 338 | 339 | (define-key global-map "C-x o" 'other-window) 340 | <>= 341 | <<+ Lisp File Header>> 342 | <<+ Test Preamble>> 343 | 344 | (use-modules (emacsy window)) 345 | (eval-when (compile load eval) 346 | (module-use! (current-module) (resolve-module '(emacsy window)))) 347 | <> 348 | <> 349 | 350 | <<+ Test Postscript>> 351 | @ 352 | -------------------------------------------------------------------------------- /src/line-pragma.nw: -------------------------------------------------------------------------------- 1 | \section{Literate Programming Support} 2 | 3 | All the code for this project is generated from \verb|emacsy.w|. To 4 | ease debugging, it is helpful to have the debug information point to 5 | the place it came from in \verb|emacsy.w| and not whatever source file 6 | it came from. The program \verb|nuweb| has a means of providing this 7 | information that works for C/C++ via the line pragma. Scheme does not 8 | support the line pragma, but the reader can fortunately be extended to 9 | support it. 10 | 11 | An example use of it might look like this: 12 | 13 | <>= 14 | (define (f x) 15 | #line 314 "increment-literately.w" 16 | (+ x 1)) 17 | @ BUG: The line pragma ends up littering the source with zero length 18 | strings, which often doesn't matter, but it can't be used everywhere 19 | especially within a particular form. I'm not entirely sure how to fix 20 | that. 21 | 22 | <>= 23 | (lambda (char port) 24 | (let ((ine (read port)) 25 | (lineno (read port)) 26 | (filename (read port))) 27 | (if (not (eq? ine 'ine)) 28 | (error (format #f "Expected '#line '; got '#~a~a ~a \"~a\"'." char ine lineno filename))) 29 | (set-port-filename! port filename) 30 | (set-port-line! port lineno) 31 | (set-port-column! port 0) 32 | ;; Return unspecified on purpose. 33 | *unspecified* 34 | )) 35 | @ One problem that popped up was I sometimes wanted to include pieces of 36 | documentation in embedded strings. Something that might end up 37 | looking like this in the source code: 38 | 39 | <>= 40 | (define (f x) 41 | "#line 352 "emacsy.w" 42 | The function f and its associated function h... 43 | #line 362 "emacsy.w" 44 | " 45 | ... 46 | @ The above code will see a string "\#line 352 " followed by a bare 47 | symbol emacsy.w, which will not do. To get around this, I implemented 48 | another reader extension that will strip out any \#l lines within it. 49 | 50 | <>= 51 | (lambda (char port) 52 | (let ((accum '())) 53 | (let loop ((entry (read-char port))) 54 | (if (or (eof-object? entry) 55 | (and (char=? #\" entry) 56 | (char=? #\# (peek-char port)) 57 | (begin (read-char port) 58 | #t))) 59 | ;; We're done 60 | (apply string (reverse accum)) 61 | (begin 62 | (if (and (char=? #\# entry) 63 | (char=? #\l (peek-char port))) 64 | ;; Drop this line 65 | (begin (read-line port) 66 | (loop (read-char port))) 67 | (begin 68 | ;; Keep and loop 69 | (set! accum (cons entry accum)) 70 | (loop (read-char port))))))))) 71 | <>= 72 | (define-module (line-pragma) 73 | #:use-module (ice-9 rdelim)) 74 | 75 | (eval-when (compile load eval) 76 | (define line-pragma-handler <>) 77 | (read-hash-extend #\l #f) 78 | (read-hash-extend #\l line-pragma-handler) 79 | #;(read-hash-extend #\" <>)) 80 | @ 81 | 82 | \subsection{[[__LINE__]] and [[__FILE__]]} 83 | 84 | Guile doesn't provide these compiler substitutions [[__LINE__]] and [[__FILE__]] like C does, but that's ok 85 | -------------------------------------------------------------------------------- /support/automake/guile.am: -------------------------------------------------------------------------------- 1 | # guile.am 2 | SUFFIXES += .c.x .cpp.x .x .go 3 | 4 | GUILE_WARNINGS = -Wformat -Wunbound-variable -Warity-mismatch -Wunused-variable 5 | 6 | %.c.x : %.c 7 | $(AM_V_GEN) $(guile_snarf) -o "$@" $(GUILE_CFLAGS) "$<" 8 | 9 | %.cpp.x : %.cpp 10 | $(AM_V_GEN) $(guile_snarf) -o "$@" $(GUILE_CFLAGS) "$<" 11 | 12 | %.go : %.scm 13 | $(AM_V_GEN) $(ENV) $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<" 14 | 15 | 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /support/automake/noweb.am: -------------------------------------------------------------------------------- 1 | # noweb.am 2 | #SUFFIXES += .nw .tex .pdf 3 | 4 | SUFFIXES = .nw .html .tex 5 | 6 | if NOWEB 7 | 8 | NOWEB_INCLUDES ?= 9 | NOWEAVE_FLAGS ?= 10 | NOWEAVE_UNWRAPPED_FLAGS ?= -n -delay 11 | NOWEAVE_HTML_FLAGS ?= -filter l2h -index -html 12 | NOWEAVE_HEADER ?= 13 | NOWEAVE_FOOTER ?= 14 | 15 | wrapper = $(abs_top_builddir)/bin/wrapper 16 | 17 | %.tex : %.nw 18 | $(AM_V_at) $(MAKE) all.defs 19 | $(AM_V_GEN) if [ -z "$(NOWEAVE_HEADER)" ] && [ -z "$(NOWEAVE_FOOTER)" ]; then \ 20 | $(noweave) $(NOWEAVE_FLAGS) -indexfrom all.defs $^ | cpif $@; \ 21 | else \ 22 | $(wrapper) -H "$(NOWEAVE_HEADER)" -F "$(NOWEAVE_FOOTER)" -- $(noweave) $(NOWEAVE_UNWRAPPED_FLAGS) -indexfrom all.defs $^ | cpif $@; \ 23 | fi 24 | 25 | # This creates a LaTeX file from that Noweb that may be easily 26 | # included into a larger TeX file. It uses a similar convention of 27 | # _name like that of Compass to denote that it is a partial TeX and 28 | # not complete. 29 | _%.tex : %.nw 30 | $(AM_V_at) $(MAKE) all.defs 31 | $(AM_V_GEN) $(noweave) $(NOWEAVE_UNWRAPPED_FLAGS) -indexfrom all.defs $^ | cpif $@ 32 | 33 | %.html : %.nw 34 | $(AM_V_GEN) $(noweave) $(NOWEAVE_HTML_FLAGS) $^ | cpif $@ 35 | 36 | warn_notangle = $(top_builddir)/bin/warn-notangle 37 | 38 | %.h : %.nw $(NOWEB_INCLUDES) 39 | $(AM_V_GEN) $(warn_notangle) -o $@ $(WARN_NOTANGLE_C_FLAGS) -- $(NOTANGLE_H_FLAGS) -R"file:$@" $^ 40 | 41 | %-test.c %.c %.cpp : %.nw $(NOWEB_INCLUDES) 42 | $(AM_V_GEN) $(warn_notangle) -o $@ $(WARN_NOTANGLE_C_FLAGS) -- $(NOTANGLE_C_FLAGS) -R"file:$@" $^ 43 | 44 | %-test.scm %.scm : %.nw $(NOWEB_INCLUDES) 45 | $(AM_V_GEN) $(warn_notangle) -o $@ $(WARN_NOTANGLE_LISP_FLAGS) -- $(NOTANGLE_LISP_FLAGS) -R"file:$@" $^ 46 | 47 | all.defs: $(NOWEB_DEFS) 48 | $(AM_V_GEN) sort -u $^ | cpif $@ 49 | 50 | %.defs: %.nw 51 | $(AM_V_GEN) nodefs $< > $@ 52 | 53 | %.nw.files : %.nw 54 | $(AM_V_GEN) $(noroots) $^ | $(GREP) file: | $(PERL) -pe 's/<>/\1/g;' | cpif $@ 55 | 56 | 57 | # %-doc.nw : %.nw _%.tex $(NOWEB_WRAPPER) 58 | # $(AM_V_GEN) (cat $(NOWEB_WRAPPER) | $(PERL) -pe "s/\\@FILE\\@/_$$(basename -s .nw $<)/;") | cpif $@ 59 | 60 | NOWEB_DEFS = $(NOWEB_FILES:.nw=.defs) 61 | NOWEB_TEXS = $(NOWEB_FILES:.nw=.tex) 62 | NOWEB_EXTRA_DIST = $(NOWEB_FILES) $(NOWEB_TEXS) $(NOWEB_DEFS) $(NOWEB_PRODUCTS) 63 | NOWEB_BUILT_FILES = $(NOWEB_TEXS) $(NOWEB_DEFS) $(NOWEB_PRODUCTS) 64 | NOWEB_CLEANFILES = $(NOWEB_TEXS) $(NOWEB_DEFS) $(NOWEB_PRODUCTS) all.defs \ 65 | $(NOWEB_DOCS:.pdf=.aux) $(NOWEB_DOCS:.pdf=.log) $(NOWEB_DOCS:.pdf=.nwi) \ 66 | $(NOWEB_DOCS:.pdf=.out) $(NOWEB_DOCS:.pdf=.tdo) $(NOWEB_DOCS:.pdf=.toc) \ 67 | $(NOWEB_DOCS:.pdf=.tex.log) $(NOWEB_DOCS) 68 | 69 | else 70 | %-test.scm %.scm %.h %-test.c %.c %.cpp %.tex : %.nw 71 | $(warning Warning: unable to update $@ from changed $< without noweb.) 72 | endif 73 | 74 | if PDFLATEX 75 | 76 | %.pdf: %.tex $(NOWEB_TEXS) 77 | $(AM_V_GEN) $(pdflatex) -draftmode -interaction=nonstopmode -halt-on-error $< 78 | noindex $< 79 | $(AM_V_GEN) $(pdflatex) -interaction=nonstopmode -halt-on-error $< 80 | 81 | pdf-local: $(NOWEB_DOCS) 82 | 83 | doc-local: pdf-local 84 | 85 | else 86 | %.pdf : %.tex 87 | $(warning Warning: unable to update $@ from changed $< without pdflatex.) 88 | 89 | endif 90 | 91 | show-doc-local: $(NOWEB_DOCS) 92 | for file in $^; do $(OPEN) $$file; done 93 | -------------------------------------------------------------------------------- /support/images/child-window-diagram.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/support/images/child-window-diagram.pdf -------------------------------------------------------------------------------- /support/images/emacsy-logo.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/support/images/emacsy-logo.pdf -------------------------------------------------------------------------------- /support/images/screenshot-small.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/support/images/screenshot-small.png -------------------------------------------------------------------------------- /support/images/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/support/images/screenshot.png -------------------------------------------------------------------------------- /support/images/the-garden.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/support/images/the-garden.pdf -------------------------------------------------------------------------------- /support/images/window-diagram.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/support/images/window-diagram.pdf -------------------------------------------------------------------------------- /support/latex/commands.tex: -------------------------------------------------------------------------------- 1 | %\input{/Users/shane/.latexrc} 2 | 3 | \DeclareMathOperator{\comp}{comp} 4 | \DeclareMathOperator{\proj}{proj} 5 | \newcommand{\px}{{\, \unit{px}}} 6 | \newcommand{\pr}{{\, \unit{pr}}} 7 | \newcommand{\where}{{\text{where}~}} 8 | \newcommand{\bv}[1]{\mathbf{#1}} 9 | \newcommand{\bhv}[1]{\mathbf{\hat{#1}}} 10 | \newcommand{\M}[1]{\mathbf{#1}} 11 | \newcommand{\defeq}{\stackrel{\text{\tiny def}}{=}} 12 | \newcommand{\R}{\mathbb{R}} 13 | \newcommand{\ie}{\emph{i.e.}} 14 | \newcommand{\eg}{\emph{e.g.}} 15 | \newcommand{\angles}[1]{{\left\langle #1 \right\rangle}} 16 | \newcommand{\red}[1]{\color{red}#1\color{black}} 17 | \newcommand{\blue}[1]{\color{blue}#1\color{black}} 18 | \newcommand{\infinity}{\infty} 19 | \newcommand{\pd}[2][]{{\partial #1 \over \partial #2}} 20 | % usage: \td[x]t -> dx/dt 21 | % usage: \td{t}x -> (d/dt) x 22 | \newcommand{\td}[2][]{{\d #1 \over \d #2}} 23 | \renewcommand{\d}{\mathrm{d}} 24 | 25 | % \DeclareMathOperator{\foo}{foo} 26 | % \operatorname{foo}(bar) 27 | 28 | \DeclareMathOperator{\tri}{tri} 29 | \newcommand{\set}{\leftarrow} 30 | \newcommand{\degree}{\ensuremath{^\circ}} 31 | \newcommand{\degrees}{\ensuremath{^\circ}} 32 | -------------------------------------------------------------------------------- /support/latex/nwmac.tex: -------------------------------------------------------------------------------- 1 | % nwmac.tex -- plain TeX support for noweb 2 | % DON'T read or edit this file! Use ...noweb-source/tex/support.nw instead. 3 | {\obeyspaces\global\let =\ } % from texbook, p 381 4 | \def\nwdocspar{\par\semifilbreak} 5 | \def\nwbackslash{\char92} 6 | \def\nwlbrace{\char123} 7 | \def\nwrbrace{\char125} 8 | \catcode`\@=11 9 | % scale cmbx10 instead of using cmbx12 because {\LaTeX} does, so fonts exist 10 | \font\twlbf=cmbx10 scaled \magstep1 11 | \font\frtbf=cmbx10 scaled \magstep2 12 | % These fonts don't work with xdvi! 13 | 14 | \advance\hoffset 0.5 true in 15 | \advance\hsize -1.5 true in 16 | \newdimen\textsize 17 | \textsize=\hsize 18 | \def\today{\ifcase\month\or 19 | January\or February\or March\or April\or May\or June\or 20 | July\or August\or September\or October\or November\or December\fi 21 | \space\number\day, \number\year} 22 | \long\def\ifundefined#1#2#3{% 23 | \expandafter\ifx\csname#1\endcsname\relax 24 | #2% 25 | \else#3% 26 | \fi} 27 | 28 | \ifundefined{myheadline} 29 | {\headline={\hbox to \textsize{\tentt\firstmark\hfil\tenrm\today\hbox 30 | to 4em{\hss\folio}}\hss}} 31 | {\expandafter\headline\expandafter{\myheadline}} 32 | 33 | \ifundefined{myfootline} 34 | {\footline={\hfil}} 35 | {\expandafter\footline\expandafter{\myfootline}} 36 | \def\semifilbreak{\vskip0pt plus1.5in\penalty-200\vskip0pt plus -1.5in} 37 | \raggedbottom 38 | % 39 | % \chapcenter macro to produce nice centered chapter titles 40 | % 41 | \def\chapcenter{\leftskip=0.5 true in plus 4em minus 0.5 true in 42 | \rightskip=\leftskip 43 | \parfillskip=0pt \spaceskip=.3333em \xspaceskip=.5em 44 | \pretolerance=9999 \tolerance=9999 45 | \hyphenpenalty=9999 \exhyphenpenalty=9999} 46 | % \startsection{LEVEL}{INDENT}{BEFORESKIP}{AFTERSKIP}{STYLE}{HEADING} 47 | % #1 #2 #3 #4 #5 #6 48 | % 49 | % LEVEL: depth; e.g. part=0 chapter=1 sectino=2... 50 | % INDENT: indentation of heading from left margin 51 | % BEFORESKIP: skip before header 52 | % AFTERSKIP: skip after header 53 | % STYLE: style of heading; e.g.\bf 54 | % HEADING: heading of the sectino 55 | % 56 | \def\startsection#1#2#3#4#5#6{\par\vskip#3 plus 2in 57 | \penalty-200\vskip 0pt plus -2in 58 | \noindent{\leftskip=#2 \rightskip=0.5true in plus 4em minus 0.5 true in 59 | \hyphenpenalty=9999 \exhyphenpenalty=9999 60 | #5#6\par}\vskip#4% 61 | {\def\code##1{[[}\def\edoc##1{]]}\message{[#6]}} 62 | \settocparms{#1} 63 | \def\themodtitle{#6} 64 | %%%% {\def\code{\string\code}\def\edoc{\string\edoc}% 65 | \edef\next{\noexpand\write\cont{\tocskip 66 | \tocline{\hskip\tocindent\tocstyle\relax\themodtitle} 67 | {\noexpand\the\pageno}}}\next % write to toc 68 | %} 69 | } 70 | \def\settocparms#1{ 71 | \count@=#1 72 | \ifnum\count@<1 73 | \def\tocskip{\vskip3ptplus1in\penalty-100 74 | \vskip0ptplus-1in}% 75 | \def\tocstyle{\bf} 76 | \def\tocindent{0pt} 77 | \else 78 | \def\tocskip{} 79 | \def\tocstyle{\rm} 80 | \dimen@=2em \advance\count@ by \m@ne \dimen@=\count@\dimen@ 81 | \edef\tocindent{\the\dimen@} 82 | \fi 83 | } 84 | \def\tocline#1#2{\line{{\ignorespaces#1}\leaders\hbox to .5em{.\hfil}\hfil 85 | \hbox to1.5em{\hss#2}}} 86 | \def\section#1{\par \vskip3ex\noindent {\bf #1}\par\nobreak\vskip1ex\nobreak} 87 | \def\chapter#1{\vfil\eject\startsection{0}{0pt}{6ex}{3ex}{\frtbf\chapcenter}{#1}} 88 | \def\section#1{\startsection{1}{0pt}{4ex}{2ex}{\twlbf}{#1}} 89 | \def\subsection#1{\startsection{2}{0pt}{2ex}{1ex}{\bf}{#1}} 90 | \def\subsubsection#1{\startsection{3}{0pt}{1ex}{0.5ex}{\it}{#1}} 91 | \def\paragraph#1{\startsection{4}{0pt}{1.5ex}{0ex}{\it}{#1}} 92 | 93 | % make \hsize in code sufficient for 88 columns 94 | \setbox0=\hbox{\tt m} 95 | \newdimen\codehsize 96 | \codehsize=91\wd0 % 88 columns wasn't enough; I don't know why 97 | \newdimen\codemargin 98 | \codemargin=0pt 99 | \newdimen\nwdefspace 100 | \nwdefspace=\codehsize 101 | % need to use \textwidth in {\LaTeX} to handle styles with 102 | % non-standard margins (David Bruce). Don't know why we sometimes 103 | % wanted \hsize. 27 August 1997. 104 | %% \advance\nwdefspace by -\hsize\relax 105 | \ifx\textwidth\undefined 106 | \advance\nwdefspace by -\hsize\relax 107 | \else 108 | \advance\nwdefspace by -\textwidth\relax 109 | \fi 110 | \chardef\other=12 111 | \def\setupcode{% 112 | \chardef\\=`\\ 113 | \chardef\{=`\{ 114 | \chardef\}=`\} 115 | \catcode`\$=\other 116 | \catcode`\&=\other 117 | \catcode`\#=\other 118 | \catcode`\%=\other 119 | \catcode`\~=\other 120 | \catcode`\_=\other 121 | \catcode`\^=\other 122 | \catcode`\"=\other % fixes problem with german.sty 123 | \obeyspaces\Tt 124 | } 125 | %\let\nwlbrace=\{ 126 | %\let\nwrbrace=\} 127 | \def\nwendquote{\relax\ifhmode\spacefactor=1000 \fi} 128 | {\catcode`\^^M=\active % make CR an active character 129 | \gdef\newlines{\catcode`\^^M=\active % make CR an active character 130 | \def^^M{\par\startline}}% 131 | \gdef\eatline#1^^M{\relax}% 132 | } 133 | %%% DON'T \gdef^^M{\par\startline}}% in case ^^M appears in a \write 134 | \def\startline{\noindent\hskip\parindent\ignorespaces} 135 | \def\nwnewline{\ifvmode\else\hfil\break\leavevmode\hbox{}\fi} 136 | \def\setupmodname{% 137 | \catcode`\$=3 138 | \catcode`\&=4 139 | \catcode`\#=6 140 | \catcode`\%=14 141 | \catcode`\~=13 142 | \catcode`\_=8 143 | \catcode`\^=7 144 | \catcode`\ =10 145 | \catcode`\^^M=5 146 | \let\nwlbrace\lbrace 147 | \let\nwrbrace\rbrace 148 | \let\{\nwlbrace 149 | \let\}\nwrbrace 150 | % bad news --- don't know what catcode to give " 151 | \Rm} 152 | \def\LA{\begingroup\maybehbox\bgroup\setupmodname\It$\langle$} 153 | \def\RA{\/$\rangle$\egroup\endgroup} 154 | \def\code{\leavevmode\begingroup\setupcode\newlines} 155 | \def\edoc{\endgroup} 156 | \let\maybehbox\relax 157 | \newbox\equivbox 158 | \setbox\equivbox=\hbox{$\equiv$} 159 | \newbox\plusequivbox 160 | \setbox\plusequivbox=\hbox{$\mathord{+}\mathord{\equiv}$} 161 | % \moddef can't have an argument because there might be \code...\edoc 162 | \def\moddef{\leavevmode\kern-\codemargin\LA} 163 | \def\endmoddef{\RA\ifmmode\equiv\else\unhcopy\equivbox\fi 164 | \nobreak\hfill\nobreak} 165 | \def\plusendmoddef{\RA\ifmmode\mathord{+}\mathord{\equiv}\else\unhcopy\plusequivbox\fi 166 | \nobreak\hfill\nobreak} 167 | \def\chunklist{% 168 | \errhelp{I changed \chunklist to \nowebchunks. 169 | I'll try to avoid such incompatible changes in the future.}% 170 | \errmessage{Use \string\nowebchunks\space instead of \string\chunklist}} 171 | \def\nowebchunks{\message{}} 172 | \def\nowebindex{\message{}} 173 | % here is support for the new-style (capitalized) font-changing commands 174 | % thanks to Dave Love 175 | \ifx\documentstyle\undefined 176 | \let\Rm=\rm \let\It=\it \let\Tt=\tt % plain 177 | \else\ifx\selectfont\undefined 178 | \let\Rm=\rm \let\It=\it \let\Tt=\tt % LaTeX OFSS 179 | \else % LaTeX NFSS 180 | \def\Rm{\reset@font\rm} 181 | \def\It{\reset@font\it} 182 | \def\Tt{\reset@font\tt} 183 | \def\Bf{\reset@font\bf} 184 | \fi\fi 185 | \ifx\reset@font\undefined \let\reset@font=\relax \fi 186 | 187 | \def\nwfilename#1{\vfil\eject\mark{#1}} 188 | 189 | \def\nwbegindocs#1{\filbreak} 190 | \def\nwenddocs{\par} 191 | \def\nwbegincode#1{\par\nobreak 192 | \begingroup\setupcode\newlines\parindent=0pt\parskip=0pt 193 | \let\oendmoddef=\endmoddef \let\oplusendmoddef=\plusendmoddef 194 | \def\endmoddef{\oendmoddef\par}\def\plusendmoddef{\oplusendmoddef\par}% 195 | \hsize=\codehsize\noindent\bchack} 196 | \def\nwendcode{\endgroup} 197 | {\catcode`\^^M=\active % make CR an active character 198 | \gdef\bchack#1^^M{\relax#1}% 199 | } 200 | \edef\contentsfile{\jobname.toc } % file that gets table of contents info 201 | \def\readcontents{\expandafter\input \contentsfile} 202 | 203 | \newwrite\cont 204 | \openout\cont=\contentsfile 205 | \write\cont{\string\catcode`\string\@=11}% a hack to make contents 206 | % take stuff in plain.tex 207 | \def\bye{% 208 | \write\cont{}% ensure that the contents file isn't empty 209 | \closeout\cont 210 | \vfil\eject\pageno=-1 % new page causes contents to be really closed 211 | \topofcontents\readcontents\botofcontents 212 | \vfil\eject\end} 213 | \def\topofcontents{\vfil\mark{{\bf Contents}}} 214 | \def\botofcontents{} 215 | \let\em=\it 216 | % used to produce an itemized (bulleted) list in plain {\TeX} 217 | % such lists can be nested 218 | % mostly useful with WEB 219 | 220 | % Usage: 221 | % \itemize 222 | % \item First thing 223 | % \item second thing 224 | % \enditemize 225 | 226 | \newcount\listlevel 227 | \listlevel=0 228 | \newdimen\itemwidth 229 | \itemwidth=3em 230 | 231 | \def\itemize{\begingroup\advance\listlevel by1 232 | \def\item{\par\noindent 233 | \raise2pt\llap{$\scriptstyle\bullet$\ }\ignorespaces}% 234 | \def\nameditem##1{\par\noindent 235 | \llap{\rlap{##1}\hskip\itemwidth}\ignorespaces}% 236 | \par\advance\leftskip by\itemwidth\advance\rightskip by0.5\itemwidth} 237 | \def\enditemize{\par\endgroup\noindent\ignorespaces} 238 | 239 | \let\begindocument=\relax 240 | \catcode`\@=12 241 | -------------------------------------------------------------------------------- /support/m4/ax_check_noweb.m4: -------------------------------------------------------------------------------- 1 | 2 | # ax_check_noweb entry point 3 | AC_DEFUN([AX_CHECK_NOWEB], 4 | [ 5 | AC_REQUIRE([AX_CHECK_OPEN]) 6 | AC_CHECK_PROG(NOWEB_CHECK,noweb,yes) 7 | if test x"$NOWEB_CHECK" != x"yes" ; then 8 | AC_MSG_WARN([Must have noweb installed to alter literate source code.]) 9 | fi 10 | AC_ARG_ENABLE([line_pragma], 11 | [AC_HELP_STRING([--enable-line-pragma=@<:@yes/no@:>@], 12 | [Enable line pragma in noweb @<:@default=no@:>@])], 13 | [], 14 | [enable_line_pragma=no]) 15 | 16 | AM_CONDITIONAL([LINE_PRAGMA], [test x"$enable_line_pragma" = xyes]) 17 | 18 | AC_ARG_ENABLE([noweb], 19 | [AC_HELP_STRING([--enable-noweb=@<:@yes/no@:>@], 20 | [Enable noweb @<:@default=yes@:>@])], 21 | [], 22 | [enable_noweb=yes]) 23 | 24 | AS_IF([test "x$enable_noweb" = "xyes"], 25 | [ 26 | AC_PATH_PROG([noweb], noweb) 27 | AC_SUBST(noweb) 28 | 29 | AC_PATH_PROG([noweave], noweave) 30 | AC_SUBST(noweave) 31 | 32 | AC_PATH_PROG([notangle], notangle) 33 | AC_SUBST(notangle) 34 | 35 | AC_PATH_PROG([noroots], noroots) 36 | AC_SUBST(noroots) 37 | 38 | AC_PATH_PROG([GREP], [grep]) 39 | AC_SUBST([GREP]) 40 | 41 | noweb_home=`AS_DIRNAME(["$noweb"])`/.. 42 | 43 | AC_PATH_PROG([markup], markup, no, [$PATH:$noweb_home/libexec/noweb:$noweb_home/lib/noweb]) 44 | if test "$markup" = "no"; then 45 | AC_MSG_ERROR([Must have noweb's markup installed to alter literate source code.]) 46 | fi 47 | AC_SUBST(markup) 48 | ], 49 | []) 50 | 51 | 52 | AM_CONDITIONAL([NOWEB], [test x"$NOWEB_CHECK" = xyes && test x"$enable_noweb" = xyes]) 53 | 54 | AC_ARG_ENABLE([pdflatex], 55 | [AC_HELP_STRING([--enable-pdflatex=@<:@yes/no@:>@], 56 | [Enable pdflatex @<:@default=yes@:>@])], 57 | [enable_pdflatex=no], 58 | [enable_pdflatex=yes]) 59 | AC_CHECK_PROG(PDFLATEX_CHECK,pdflatex,yes) 60 | if test x"$PDFLATEX_CHECK" != x"yes" ; then 61 | AC_MSG_WARN([Must have pdflatex installed to produce PDFs.]) 62 | fi 63 | AM_CONDITIONAL([PDFLATEX], [test x"$PDFLATEX_CHECK" = xyes && test x"$enable_pdflatex" = xyes]) 64 | AC_PATH_PROG([pdflatex], pdflatex) 65 | AC_SUBST(pdflatex) 66 | ]) 67 | 68 | 69 | -------------------------------------------------------------------------------- /support/m4/ax_check_open.m4: -------------------------------------------------------------------------------- 1 | 2 | AC_DEFUN([AX_CHECK_OPEN], 3 | [ 4 | AC_REQUIRE([AC_CANONICAL_HOST]) 5 | AS_CASE([${host}], 6 | [*-darwin*], 7 | [ 8 | AC_PATH_PROG([OPEN], open) 9 | AC_SUBST(OPEN) 10 | ], 11 | [ 12 | AC_PATH_PROG([OPEN], gnome-open) 13 | AC_SUBST(OPEN) 14 | ]) 15 | ]) 16 | -------------------------------------------------------------------------------- /support/m4/ax_lang_compiler_ms.m4: -------------------------------------------------------------------------------- 1 | # -*- mode: autoconf -*- 2 | # 3 | # Check whether the compiler for the current language is Microsoft. 4 | # 5 | # This macro is modeled after _AC_LANG_COMPILER_GNU in the GNU Autoconf 6 | # implementation. 7 | # 8 | # version: 1.0 9 | # author: Braden McDaniel 10 | # 11 | # This program is free software; you can redistribute it and/or modify 12 | # it under the terms of the GNU General Public License as published by 13 | # the Free Software Foundation; either version 2, or (at your option) 14 | # any later version. 15 | # 16 | # This program is distributed in the hope that it will be useful, 17 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | # GNU General Public License for more details. 20 | # 21 | # You should have received a copy of the GNU General Public License 22 | # along with this program; if not, write to the Free Software 23 | # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 24 | # 02110-1301, USA. 25 | # 26 | # As a special exception, the you may copy, distribute and modify the 27 | # configure scripts that are the output of Autoconf when processing 28 | # the Macro. You need not follow the terms of the GNU General Public 29 | # License when using or distributing such scripts. 30 | # 31 | AC_DEFUN([AX_LANG_COMPILER_MS], 32 | [AC_CACHE_CHECK([whether we are using the Microsoft _AC_LANG compiler], 33 | [ax_cv_[]_AC_LANG_ABBREV[]_compiler_ms], 34 | [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[#ifndef _MSC_VER 35 | choke me 36 | #endif 37 | ]])], 38 | [ax_compiler_ms=yes], 39 | [ax_compiler_ms=no]) 40 | ax_cv_[]_AC_LANG_ABBREV[]_compiler_ms=$ax_compiler_ms 41 | ])]) 42 | -------------------------------------------------------------------------------- /support/noweb/boiler-plate.nw: -------------------------------------------------------------------------------- 1 | \section{Boiler Plate} 2 | \subsection{C Code} 3 | <<+ Preamble>>= 4 | /* 5 | DO NOT EDIT - This file was automatically generated from a noweb source file. 6 | */ 7 | <<+ Copyright>> 8 | <<+ License>> 9 | @ 10 | <<+ Begin C Header Guard.>>= 11 | 12 | #ifdef __cplusplus 13 | extern "C" { 14 | #endif 15 | <<+ End C Header Guard.>>= 16 | 17 | #ifdef __cplusplus 18 | } 19 | #endif 20 | @ \subsection{Legal Stuff} 21 | <<+ Copyright>>= 22 | Copyright (C) 2012 Shane Celis 23 | @ 24 | <<+ License>>= 25 | This program is free software: you can redistribute it and/or modify 26 | it under the terms of the GNU General Public License as published by 27 | the Free Software Foundation, either version 3 of the License, or 28 | (at your option) any later version. 29 | 30 | This program is distributed in the hope that it will be useful, 31 | but WITHOUT ANY WARRANTY; without even the implied warranty of 32 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 33 | GNU General Public License for more details. 34 | 35 | You should have received a copy of the GNU General Public License 36 | along with this program. If not, see . 37 | @ 38 | \subsection{Lisp Code} 39 | 40 | <<+ Lisp Preamble>>= 41 | #| FILENAME 42 | DO NOT EDIT - automatically generated from FILENAME. 43 | 44 | <<+ Copyright>> 45 | <<+ License>> 46 | |# 47 | @ 48 | 49 | <<+ Test Preamble>>= 50 | (use-modules (check)) 51 | (use-modules (ice-9 pretty-print)) 52 | (define test-errors '()) 53 | @ 54 | 55 | <<+ Test Postscript>>= 56 | ;(run-tests) 57 | (check-report) 58 | '(if (> (length test-errors) 0) 59 | (format #t "~a ERROR in tests: ~a." (length test-errors) (reverse test-errors)) 60 | (format #t "NO ERRORs in tests.")) 61 | (exit (if (and (= (length test-errors) 0) (= 0 (length check:failed))) 0 1)) 62 | @ 63 | -------------------------------------------------------------------------------- /support/noweb/paper-footer.nw: -------------------------------------------------------------------------------- 1 | 2 | \paragraph{Defined Chunks}\par\noindent 3 | \nowebchunks 4 | \paragraph{Index}\par\noindent 5 | \nowebindex 6 | @ 7 | \end{document} 8 | -------------------------------------------------------------------------------- /support/noweb/paper-header.nw: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | \usepackage{graphicx} 3 | \usepackage{amsmath} 4 | \usepackage{amssymb} 5 | \usepackage{float} 6 | \usepackage{upgreek} 7 | \usepackage{todonotes} 8 | \usepackage{color} 9 | \definecolor{linkcolor}{rgb}{0, 0, 0.7} 10 | \usepackage[backref,raiselinks,pdfhighlight=/O,pagebackref,hyperfigures,breaklinks,colorlinks,pdfstartview=FitBH,linkcolor={linkcolor},anchorcolor={linkcolor},citecolor={linkcolor},filecolor={linkcolor},menucolor={linkcolor},pagecolor={linkcolor},urlcolor={linkcolor}]{hyperref} 11 | \usepackage{epigraph} 12 | \usepackage{cleveref} 13 | \input{/Users/shane/.latexrc} 14 | \usepackage{noweb} 15 | \pagestyle{noweb} 16 | \noweboptions{externalindex,longxref} 17 | 18 | \begin{document} 19 | 20 | -------------------------------------------------------------------------------- /support/noweb/paper-wrapper.nw: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | \usepackage{graphicx} 3 | \usepackage{amsmath} 4 | \usepackage{amssymb} 5 | \usepackage{float} 6 | \usepackage{upgreek} 7 | \usepackage{todonotes} 8 | \usepackage{color} 9 | \definecolor{linkcolor}{rgb}{0, 0, 0.7} 10 | \usepackage[backref,raiselinks,pdfhighlight=/O,pagebackref,hyperfigures,breaklinks,colorlinks,pdfstartview=FitBH,linkcolor={linkcolor},anchorcolor={linkcolor},citecolor={linkcolor},filecolor={linkcolor},menucolor={linkcolor},pagecolor={linkcolor},urlcolor={linkcolor}]{hyperref} 11 | \usepackage{epigraph} 12 | \usepackage{cleveref} 13 | \input{/Users/shane/.latexrc} 14 | \usepackage{noweb} 15 | \pagestyle{noweb} 16 | \noweboptions{externalindex,longxref} 17 | 18 | \begin{document} 19 | 20 | \input{@FILE@} 21 | 22 | \paragraph{Defined Chunks}\par\noindent 23 | \nowebchunks 24 | \paragraph{Index}\par\noindent 25 | \nowebindex 26 | @ 27 | \end{document} 28 | -------------------------------------------------------------------------------- /support/pkg-config/Makefile.am: -------------------------------------------------------------------------------- 1 | pkgconfigdir = $(libdir)/pkgconfig 2 | pkgconfig_DATA = guile-noweb-autotools.pc 3 | 4 | MAINTAINERCLEANFILES = guile-noweb-autotools.pc Makefile.in 5 | -------------------------------------------------------------------------------- /support/pkg-config/emacsy.pc.in: -------------------------------------------------------------------------------- 1 | prefix=@prefix@ 2 | exec_prefix=@exec_prefix@ 3 | libdir=@libdir@ 4 | includedir=@includedir@ 5 | 6 | Name: Emacsy 7 | Description: An Emacs-like Library for GNU Guile Scheme 8 | URL: https://github.com/shanecelis/emacsy 9 | Version: @VERSION@ 10 | Requires: guile-2.0 11 | Libs: -L${libdir} -lemacsy 12 | Cflags: -I${includedir} 13 | -------------------------------------------------------------------------------- /support/pkg-config/not-installed/emacsy.pc.in: -------------------------------------------------------------------------------- 1 | prefix=@abs_top_builddir@ 2 | exec_prefix=@exec_prefix@ 3 | libdir=@abs_top_builddir@/src/emacsy/.libs 4 | includedir=@abs_top_builddir@/src/emacsy 5 | moduledir=@abs_top_builddir@/src/ 6 | 7 | Name: Emacsy 8 | Description: Run this directly from the source directory (not-installed). 9 | URL: https://github.com/shanecelis/emacsy 10 | Version: @VERSION@ 11 | Requires: guile-2.0 12 | Libs: -L${libdir} -lemacsy 13 | Cflags: -I${includedir} 14 | -------------------------------------------------------------------------------- /support/scheme/check.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ; Copyright (c) 2005-2006 Sebastian Egner. 3 | ; 4 | ; Permission is hereby granted, free of charge, to any person obtaining 5 | ; a copy of this software and associated documentation files (the 6 | ; ``Software''), to deal in the Software without restriction, including 7 | ; without limitation the rights to use, copy, modify, merge, publish, 8 | ; distribute, sublicense, and/or sell copies of the Software, and to 9 | ; permit persons to whom the Software is furnished to do so, subject to 10 | ; the following conditions: 11 | ; 12 | ; The above copyright notice and this permission notice shall be 13 | ; included in all copies or substantial portions of the Software. 14 | ; 15 | ; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, 16 | ; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 17 | ; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | ; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 19 | ; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 20 | ; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 21 | ; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 22 | ; 23 | ; ----------------------------------------------------------------------- 24 | ; 25 | ; Lightweight testing (reference implementation) 26 | ; ============================================== 27 | ; 28 | ; Sebastian.Egner@philips.com 29 | ; in R5RS + SRFI 23 (error) + SRFI 42 (comprehensions) 30 | ; 31 | ; history of this file: 32 | ; SE, 25-Oct-2004: first version based on code used in SRFIs 42 and 67 33 | ; SE, 19-Jan-2006: (arg ...) made optional in check-ec 34 | ; 35 | ; Naming convention "check:<identifier>" is used only internally. 36 | 37 | ; -- portability -- 38 | 39 | ; PLT: (require (lib "23.ss" "srfi") (lib "42.ss" "srfi")) 40 | ; Scheme48: ,open srfi-23 srfi-42 41 | 42 | ; -- utilities -- 43 | 44 | (define-module (check) 45 | ;; #:use-module (ice-9 syncase) 46 | #:export (check-set-mode! 47 | check:mode 48 | check-reset! 49 | check-passed? 50 | check:failed 51 | check-report 52 | check-exit 53 | ) 54 | #:export-syntax (check check-throw check-true check-false use-private-modules) 55 | ) 56 | 57 | (define check:write write) 58 | 59 | ; You can also use a pretty printer if you have one. 60 | ; However, the output might not improve for most cases 61 | ; because the pretty printers usually output a trailing 62 | ; newline. 63 | 64 | ; PLT: (require (lib "pretty.ss")) (define check:write pretty-print) 65 | ; Scheme48: ,open pp (define check:write p) 66 | 67 | ; -- mode -- 68 | 69 | (define check:mode #f) 70 | 71 | (define (check-set-mode! mode) 72 | (set! check:mode 73 | (case mode 74 | ((off) 0) 75 | ((summary) 1) 76 | ((report-failed) 10) 77 | ((report) 100) 78 | (else (error "unrecognized mode" mode))))) 79 | 80 | (check-set-mode! 'report) 81 | 82 | ; -- state -- 83 | 84 | (define check:correct #f) 85 | (define check:failed #f) 86 | (define check:error #f) 87 | 88 | (define (check-reset!) 89 | (set! check:correct 0) 90 | (set! check:failed '())) 91 | 92 | (define (check:add-correct!) 93 | (set! check:correct (+ check:correct 1))) 94 | 95 | (define (check:add-failed! expression actual-result expected-result) 96 | (set! check:failed 97 | (cons (list expression actual-result expected-result) 98 | check:failed))) 99 | 100 | (check-reset!) 101 | 102 | ; -- reporting -- 103 | 104 | (define (check:report-expression expression) 105 | (newline) 106 | (check:write expression) 107 | (display " => ")) 108 | 109 | (define (check:report-actual-result actual-result) 110 | (check:write actual-result) 111 | (display " ; ")) 112 | 113 | (define (check:report-correct cases) 114 | (display "correct") 115 | (if (not (= cases 1)) 116 | (begin (display " (") 117 | (display cases) 118 | (display " cases checked)"))) 119 | (newline)) 120 | 121 | (define (check:report-failed expected-result) 122 | (display "*** failed ***") 123 | (newline) 124 | (display " ; expected result: ") 125 | (check:write expected-result) 126 | (newline)) 127 | 128 | (define (check-report) 129 | (if (>= check:mode 1) 130 | (begin 131 | (newline) 132 | (display "; *** checks *** : ") 133 | (display check:correct) 134 | (display " correct, ") 135 | (display (length check:failed)) 136 | (display " failed.") 137 | (if (or (null? check:failed) (<= check:mode 1)) 138 | (newline) 139 | (let* ((w (car (reverse check:failed))) 140 | (expression (car w)) 141 | (actual-result (cadr w)) 142 | (expected-result (caddr w))) 143 | (display " First failed example:") 144 | (newline) 145 | (check:report-expression expression) 146 | (check:report-actual-result actual-result) 147 | (check:report-failed expected-result)))))) 148 | 149 | (define (check-passed? expected-total-count) 150 | (and (= (length check:failed) 0) 151 | (= check:correct expected-total-count))) 152 | 153 | ; -- simple checks -- 154 | 155 | (define (check:proc expression thunk equal expected-result) 156 | (case check:mode 157 | ((0) #f) 158 | ((1) 159 | (let ((actual-result (thunk))) 160 | (if (equal actual-result expected-result) 161 | (check:add-correct!) 162 | (check:add-failed! expression actual-result expected-result)))) 163 | ((10) 164 | (let ((actual-result (thunk))) 165 | (if (equal actual-result expected-result) 166 | (check:add-correct!) 167 | (begin 168 | (check:report-expression expression) 169 | (check:report-actual-result actual-result) 170 | (check:report-failed expected-result) 171 | (check:add-failed! expression actual-result expected-result))))) 172 | ((100) 173 | (check:report-expression expression) 174 | (let ((actual-result (thunk))) 175 | (check:report-actual-result actual-result) 176 | (if (equal actual-result expected-result) 177 | (begin (check:report-correct 1) 178 | (check:add-correct!)) 179 | (begin (check:report-failed expected-result) 180 | (check:add-failed! expression 181 | actual-result 182 | expected-result))))) 183 | (else (error "unrecognized check:mode" check:mode))) 184 | (if #f #f)) 185 | 186 | (define-syntax check 187 | (syntax-rules (=>) 188 | ((check expr => expected) 189 | (check expr (=> equal?) expected)) 190 | ((check expr (=> equal) expected) 191 | (if (>= check:mode 1) 192 | (check:proc 'expr (lambda () expr) equal expected))))) 193 | 194 | (define-syntax check-throw 195 | (syntax-rules (=>) 196 | ((check-throw expr => expected-key) 197 | (check:proc 'expr (lambda () 198 | (let ((thrown-key 'no-throw)) 199 | (catch #t 200 | (lambda () expr) 201 | (lambda (key . args) 202 | (set! thrown-key key))) 203 | thrown-key)) equal? expected-key)) 204 | ((check-throw expr) 205 | (check-throw expr => 'no-throw)))) 206 | 207 | (define-syntax check-true 208 | (syntax-rules () 209 | ((check-true expr) 210 | (check (if expr #t #f) => #t)))) 211 | 212 | (define-syntax check-false 213 | (syntax-rules () 214 | ((check-false expr) 215 | (check expr => #f)))) 216 | 217 | 218 | ; -- parametric checks -- 219 | 220 | (define (check:proc-ec w) 221 | (let ((correct? (car w)) 222 | (expression (cadr w)) 223 | (actual-result (caddr w)) 224 | (expected-result (cadddr w)) 225 | (cases (car (cddddr w)))) 226 | (if correct? 227 | (begin (if (>= check:mode 100) 228 | (begin (check:report-expression expression) 229 | (check:report-actual-result actual-result) 230 | (check:report-correct cases))) 231 | (check:add-correct!)) 232 | (begin (if (>= check:mode 10) 233 | (begin (check:report-expression expression) 234 | (check:report-actual-result actual-result) 235 | (check:report-failed expected-result))) 236 | (check:add-failed! expression 237 | actual-result 238 | expected-result))))) 239 | 240 | (define-syntax check-ec:make 241 | (syntax-rules (=>) 242 | ((check-ec:make qualifiers expr (=> equal) expected (arg ...)) 243 | (if (>= check:mode 1) 244 | (check:proc-ec 245 | (let ((cases 0)) 246 | (let ((w (first-ec 247 | #f 248 | qualifiers 249 | (:let equal-pred equal) 250 | (:let expected-result expected) 251 | (:let actual-result 252 | (let ((arg arg) ...) ; (*) 253 | expr)) 254 | (begin (set! cases (+ cases 1))) 255 | (if (not (equal-pred actual-result expected-result))) 256 | (list (list 'let (list (list 'arg arg) ...) 'expr) 257 | actual-result 258 | expected-result 259 | cases)))) 260 | (if w 261 | (cons #f w) 262 | (list #t 263 | '(check-ec qualifiers 264 | expr (=> equal) 265 | expected (arg ...)) 266 | (if #f #f) 267 | (if #f #f) 268 | cases))))))))) 269 | 270 | ; (*) is a compile-time check that (arg ...) is a list 271 | ; of pairwise disjoint bound variables at this point. 272 | 273 | (define-syntax check-ec 274 | (syntax-rules (nested =>) 275 | ((check-ec expr => expected) 276 | (check-ec:make (nested) expr (=> equal?) expected ())) 277 | ((check-ec expr (=> equal) expected) 278 | (check-ec:make (nested) expr (=> equal) expected ())) 279 | ((check-ec expr => expected (arg ...)) 280 | (check-ec:make (nested) expr (=> equal?) expected (arg ...))) 281 | ((check-ec expr (=> equal) expected (arg ...)) 282 | (check-ec:make (nested) expr (=> equal) expected (arg ...))) 283 | 284 | ((check-ec qualifiers expr => expected) 285 | (check-ec:make qualifiers expr (=> equal?) expected ())) 286 | ((check-ec qualifiers expr (=> equal) expected) 287 | (check-ec:make qualifiers expr (=> equal) expected ())) 288 | ((check-ec qualifiers expr => expected (arg ...)) 289 | (check-ec:make qualifiers expr (=> equal?) expected (arg ...))) 290 | ((check-ec qualifiers expr (=> equal) expected (arg ...)) 291 | (check-ec:make qualifiers expr (=> equal) expected (arg ...))) 292 | 293 | ((check-ec (nested q1 ...) q etc ...) 294 | (check-ec (nested q1 ... q) etc ...)) 295 | ((check-ec q1 q2 etc ...) 296 | (check-ec (nested q1 q2) etc ...)))) 297 | 298 | ;; XXX I added this just so I could integrate it with unit tests. 299 | (define (check-exit) 300 | (exit (if (and #;(= (length test-errors) 0) 301 | (= 0 (length check:failed))) 0 1))) 302 | 303 | ;; Include everything a module uses including its non-exported 304 | ;; interface. This is intended to be used with unit testing ONLY! 305 | (define-syntax use-private-modules 306 | (syntax-rules () 307 | ((use-private-modules . modules) 308 | (eval-when (compile load eval) 309 | ;; Some trickery so we can test private procedures. 310 | (for-each (lambda (module) 311 | (module-use! (current-module) (resolve-module module))) 312 | 'modules))))) 313 | -------------------------------------------------------------------------------- /support/scheme/float-equality.scm: -------------------------------------------------------------------------------- 1 | (define-module (float-equality) 2 | #:use-module (ice-9 optargs) 3 | #:use-module (oop goops) 4 | #:use-module (srfi srfi-1) ;; fold 5 | #:export (=?)) 6 | 7 | (define-method (=? (a <number>) (b <number>) . rest) 8 | (let-optional rest ((tolerance 0.001)) 9 | (< (abs (- a b)) tolerance))) 10 | 11 | (define-method (=? (a <list>) (b <list>) . rest) 12 | (fold (lambda (x y prev) 13 | (and prev (apply =? x y rest))) #t a b)) 14 | 15 | (define-method (=? (a <pair>) (b <pair>) . rest) 16 | (and (apply =? (car a) (car b) rest) 17 | (apply =? (cdr a) (cdr b) rest))) 18 | 19 | 20 | (define-method (=? (a <vector>) (b <vector>) . rest) 21 | (apply =? (vector->list a) (vector->list b) rest)) 22 | 23 | (define-method (=? (a <uvec>) (b <uvec>) . rest) 24 | (apply =? (generalized-vector->list a) (generalized-vector->list b) rest)) 25 | 26 | (define-method (=? a b . rest) 27 | #f) 28 | 29 | (define-method (=? (tolerance <number>)) 30 | (lambda (a b) 31 | (=? a b tolerance))) 32 | 33 | -------------------------------------------------------------------------------- /test/Makefile.am: -------------------------------------------------------------------------------- 1 | #TESTS_ENVIRONMENT = /bin/bash -x 2 | TEST_EXTENSIONS = .sh 3 | SH_LOG_COMPILER = /bin/bash -x 4 | EXTRA_DIST = minibuffer-test-dir dummy.sh 5 | 6 | # These tests end up doing double the work because they create another 7 | # distdir. Also, should a dist necessarily be able to create another dist? 8 | 9 | # These tests should be kept separate as release tests since they're 10 | # so expensive. 11 | 12 | #TESTS= works-without-noweb.sh print-install.sh 13 | TESTS= dummy.sh 14 | 15 | MAINTAINERCLEANFILES = Makefile.in works-without-noweb.sh print-install.sh 16 | -------------------------------------------------------------------------------- /test/dummy.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # dummy.sh 3 | # 4 | # This dummy test doesn't do anything but pass. 5 | -------------------------------------------------------------------------------- /test/minibuffer-test-dir/bin/run-test: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/test/minibuffer-test-dir/bin/run-test -------------------------------------------------------------------------------- /test/minibuffer-test-dir/empty-dir/.dummy: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/test/minibuffer-test-dir/empty-dir/.dummy -------------------------------------------------------------------------------- /test/minibuffer-test-dir/exam/.dummy: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/test/minibuffer-test-dir/exam/.dummy -------------------------------------------------------------------------------- /test/minibuffer-test-dir/minibuffer-a: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/test/minibuffer-test-dir/minibuffer-a -------------------------------------------------------------------------------- /test/minibuffer-test-dir/minibuffer-b: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shanecelis/emacsy/fd1ff6a439a202bd645711cf9dbff9da111d40f7/test/minibuffer-test-dir/minibuffer-b -------------------------------------------------------------------------------- /test/print-install.sh.in: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # print-install.sh.in 3 | set -e; # abort if anything fails 4 | builddir="@abs_top_builddir@" 5 | cd $builddir 6 | make distdir 7 | dirname=@DISTDIR@ 8 | cd $dirname 9 | ./configure --prefix="$builddir/print-install" 10 | 11 | # Make sure it can be built without noweb and cleaned without removing 12 | # anything important. 13 | make clean 14 | make 15 | make install 16 | cd $builddir 17 | find "print-install" 18 | rm -rf "$builddir/print-install" 19 | -------------------------------------------------------------------------------- /test/works-without-noweb.sh.in: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # works-without-noweb 3 | set -e; # abort if anything fails 4 | cd @top_builddir@ 5 | make distdir 6 | dirname=@DISTDIR@ 7 | cd $dirname 8 | ./configure --enable-noweb=no --enable-pdflatex=no 9 | 10 | # Make sure it can be built without noweb and cleaned without removing 11 | # anything important. 12 | make 13 | #make pdf 14 | make clean 15 | make 16 | -------------------------------------------------------------------------------- /todo.org: -------------------------------------------------------------------------------- 1 | * Emacsy TODO 2 | - [X] Defining variables with define-variable leaves warnings about 3 | that variable not being defined. FIXED. Thanks, Mark Weaver! 4 | - [ ] Change emacsy-key-event to emacsy-submit-key-event or something. 5 | - [ ] rename define-cmd to define-command 6 | - [ ] BUG: The frame title should show the current buffer whereas the 7 | modeline show's the window's buffer 8 | - [ ] hello-emacsy BUG: C-u 1 0 doesn't show latest character. 9 | - [ ] It'd be nice to have a for-each which didn't use lambdas and 10 | was more like loop. The for-each action list where action can be 11 | long then the list that it operates on is kind of jaring.) 12 | - [ ] Maybe there should be hook such that a REPL can be invoked 13 | from within Emacsy that then in the simplest case reports the port 14 | and hostname. Or perhaps invokes Emacs to enter it. 15 | - [X] How to implement defvar: Use [[http://www.gnu.org/software/guile/manual/guile.html#Object-Properties][object-properties]] on the variable 16 | from (module-variable). Thanks, Andy! 17 | - [X] Incorporating modifier keys should be easy. Split <key-event> 18 | into <modifier-key-event> and <key-event. 19 | - [X] Need to pick up modifier-keys from GLFW. 20 | - [X] Remove (kbd "C-...") It's useless noise. 21 | - [X] Need to fix history. Just make an indexable list class. 22 | - [X] cursor-list now exists. 23 | 24 | - How to make a trampoline out of a symbol, by mark_weaver: 25 | 26 | (define (make-trampoline s) 27 | (compile `(lambda () (,s)) #:env 28 | <desired-module>)) 29 | 30 | here's an implementation of 'make-trampoline' that uses vastly less 31 | memory per trampoline, and avoids loading the compiler: (define 32 | (make-trampoline module name) (let ((var (module-variable module 33 | name))) (lambda () ((variable-ref var))))) 34 | 35 | - [ ] Come up with a way to export commands so that one can indicate 36 | what modules one wants to use. 37 | 38 | 1. Let the user do it by creating their own modules. 39 | 40 | Nice idea because it requires no new infrastructure. Might 41 | encourage the proliferation of new modules. 42 | 43 | 2. Let the user export certain symbols as commands. Pretty much 44 | like a new kind of public interface. 45 | 46 | Requires some infrastructure. Possibly want to use this 47 | generally to collect up all kinds of other things. So far I've 48 | had commands and fitness functions. Other things might come 49 | along as well. 50 | 51 | (export-commands this that yon) 52 | 53 | (emacsy-export commands '(this that yon)) 54 | 55 | (emacsy-export fitness-function '(this that yon)) 56 | 57 | %emacsy-local-modules 58 | 59 | 60 | 3. Do what I'm doing now where the user has to define their name 61 | for something. 62 | 63 | 4. Just make a list of the symbols. Nothing fancy. If someone 64 | wants only the commands, they do this: 65 | 66 | (resolve-interface '(that-module) #:select (@ (that-module) commands)) 67 | 68 | (resolve-interface '(that-module %command) 69 | 70 | (use-modules ((that-module) #:select (@commands)) 71 | 72 | 73 | - [ ] rename read-file-name to EITHER read-filename OR 74 | read-filename-from-minibuffer 75 | - [ ] have backtraces go to logs 76 | - [X] Rethink the commands. Can't we keep them as simple lambdas? 77 | Do we have to wrap them? 78 | 79 | Also, when the user provides the symbol of a function, let's 80 | create a trampoline to that function. Otherwise, if they provide 81 | a lambda, run that lambda. 82 | 83 | - [X] If module (emacsy emacsy) does not load, it may be because it did 84 | not compile. Please show the correct error. FIXED. 85 | - [X] Make the read-from-minibuffer accept a symbol for a history 86 | - [X] Turn history into an object/record rather than a list and an 87 | index. Need a list with a cursor or a zipper; can use 2 lists for 88 | what's in front and behind the current position. 89 | - [ ] Rename EY_* C macros to EMACSY_SAME_NAME_AS_SCHEME_OK_P 90 | - [X] Make the default read-from-minibuffer history symbol be (what-command-am-i) 91 | - [-] Add a couple of variations on the webkit browser 92 | - [X] make it use multiple buffers 93 | - [ ] make it use multiple windows 94 | - [ ] Should (emacsy window) always be loaded but default to not 95 | supporting multiple windows? 96 | 97 | - [ ] 98 | 99 | - [ ] get rid of noise in emacsy (noise?) log noise? 100 | - [ ] Change define-cmd to define-command 101 | - [ ] implement coroutines in Guile using [[http://www.lua.org/manual/5.2/manual.html][Lua API]] and [[http://wingolog.org/archives/2011/08/30/the-gnu-extension-language][this]] as a basis 102 | It'd be nice if the coroutines were interruptable. Maybe [[http://lists.gnu.org/archive/html/guile-user/2011-10/msg00038.html][this would help.]] 103 | This is a [[http://pllab.is.ocha.ac.jp/~asai/cw2011tutorial/main-e.pdf][good tutorial]] on shift and reset. 104 | 105 | Commands should be marked as suspendable. Suspendable commands 106 | will be executed in their own coroutine that may be suspended, 107 | resumed, resumed in the background, or killed. This is similar to 108 | the split between builtin commands in shell and regular commands. 109 | God, this is going to be COOL! 110 | 111 | 112 | - [X] make debugging work in emacsy 113 | Getting better with debug-on-error? 114 | - [ ] fix kill of all buffers bug 115 | - [X] add universal argument C-u 116 | - [ ] clear the echo area once other messages start to come. 117 | - [X] figure out how to integrate a browser window, it'll show pdf 118 | graphs, images, etc. too! 119 | - [X] there should be a way to turn off the display/runloop from 120 | happening. Or maybe not. Maybe the batch-mode or non-interactive 121 | mode for Emacsy shouldn't include Emacsy at all. It should just 122 | be regular Guile that one reverts to. This has the added 123 | advantage that one ends up creating Guile modules that others can 124 | use. 125 | - [ ] Add re-export-module macro, and do it as you build everything up. 126 | - [ ] (define (get-cid) (yield (lambda (resume) (resume (coroutine->cid resume))))) 127 | - [ ] make emacsy work with copy/paste [[http://stackoverflow.com/questions/6888862/how-to-access-clipboard-data-programmatically][link]] 128 | 129 | - [ ] Have something for blocking reading, need something for 130 | blocking/smartly doing writing (message) shouldn't cause an 131 | enormous hassle for unit testing like it does now. 132 | 133 | - [ ] [[https://github.com/technomancy/find-file-in-project/blob/master/find-file-in-project.el][Try this find-file-in-project]] 134 | - [[https://groups.google.com/forum/m/?fromgroups#!msg/comp.emacs/j_fNPgtbavM/DVygGrzgQgMJ][Great introduction]] to the bare minimum you need to know to use 135 | Emacs 136 | - How to make [[http://www.gnu.org/software/guile/docs/docs-2.0/guile-ref/Identifier-Macros.html#Identifier-Macros][variable aliases]] 137 | - Note: the noweb filter docs2comments does not work with noweb's line pragmas 138 | - how to do [[https://github.com/davexunit/gnumaku/blob/rebirth/gnumaku/coroutine.scm][coroutines]] in guile 139 | - [ ] How do syscalls work when Emacsy is in batch mode? 140 | 141 | Populate event buffer from file handle? Are syscalls even required 142 | if we're not in interactive mode? 143 | - [X] In order to terminate potential rogue coroutines, I could set 144 | a posix alarm that runs every second or so to check the events. 145 | - Readline already offers some completion functions for files 146 | and defines. 147 | http://www.gnu.org/software/guile/manual/guile.html#Readline-Functions 148 | - [[http://ergoemacs.org/emacs/emacs_modernization.html][Emacs modernization]] may have some good ideas to apply to Emacsy 149 | - [ ] How to test Emacsy interactions? It should accept a filehandle that 150 | specifies events and plays them back like a macro. 151 | - [[http://cygwin.com/ml/guile-emacs/2000-q2/msg00029.html][These folks]] are thinking similarly about how to deal with 152 | commands running in the background 153 | - [X] Change shebang lines from #!/usr/bin/env perl to #!@PERL@ etc. 154 | - [ ] configure.ac needs to deal with the case where no hello-emacsy 155 | is available. 156 | - [X] GLUT needs to be checked at configure time on other OSes. 157 | - An interesting way to [[http://lists.gnu.org/archive/html/guile-user/2011-10/msg00038.html][debug at the prompt]] in Guile 158 | - [ ] Use DBus as a way to interoperate between Emacsy applications. 159 | - [ ] Swap out blocking module for either ethreads or another 160 | general continuation method. 161 | - [ ] Fix bug with (define-interactive name (let ((x 1)) (lambda () (incr! x)))) 162 | - [ ] Fix bug with define-interactive not using documentation strings. 163 | - [ ] Idea: Maybe create an eshell like mode where the BNF from bash 164 | is used as a command mode for scheme. shelly? gash? bashy? 165 | - [ ] Integrate noweb into guile, such that guile will run off noweb 166 | files. Guile [[http://draketo.de/light/english/wisp-lisp-indentation-preprocessor#v0.5-repl][wisp]] already shows how to do it. 167 | * Trying to rework block code into something more malleable. 168 | (define* (wait #:optional (delay 1)) 169 | "Yield coroutine and schdule the continuation to be run after DELAY 170 | ticks." 171 | (yield (lambda (resume) (agenda-schedule resume delay)))) 172 | 173 | (define* (suspend) 174 | "Yield coroutine and schdule the continuation to be run after DELAY 175 | ticks." 176 | (yield (lambda (resume) (agenda-schedule resume delay)))) 177 | 178 | (foreground) must happen outside the coroutine. 179 | 180 | (define-command (suspend) 181 | (cosignal 'suspend foreground-cid)) 182 | 183 | (define-command (interrupt) 184 | (cosignal 'interrupt foreground-cid)) 185 | 186 | (define (cosignal sig cid) 187 | ((cid->resume cid) 'signal 188 | (case sig 189 | ((kill) 190 | (lambda () (coexit -1))) 191 | ((suspend) 192 | (lambda () ())) 193 | ((continue) 194 | (lambda () ())) 195 | 196 | ) 197 | )) 198 | 199 | (define (coexit code) 200 | (yield (lambda (resume) code))) 201 | 202 | (define (coexit . args) 203 | (yield (lambda (resume) (apply values args))) 204 | 205 | cid <-> coroutine 206 | 207 | 208 | 209 | (cowait cid-1 cid-2) 210 | 211 | 212 | Does suspend happen inside or outside the coroutine? Signals happened 213 | from outside the process in unix. 214 | --------------------------------------------------------------------------------