commit 66aed0320f92729e724c763e0f38868d5d937a9b
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 7 May 2017 03:17:42 +0200
Initial commit
Diffstat:
10 files changed, 312 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1,6 @@
+*~
+\#*
+.\#*
+.DS_Store
+compiled/
+/doc/
diff --git a/.travis.yml b/.travis.yml
@@ -0,0 +1,38 @@
+language: c
+sudo: false
+
+env:
+ global:
+ # RACKET_DIR is an argument to install-racket.sh
+ - RACKET_DIR=~/racket
+ - PATH="$RACKET_DIR/bin:$PATH"
+ matrix:
+ # RACKET_VERSION is an argument to install-racket.sh
+ - RACKET_VERSION=6.0 COV=false
+ - RACKET_VERSION=6.1 COV=false
+ - RACKET_VERSION=6.1.1 COV=false
+ - RACKET_VERSION=6.2 COV=false
+ - RACKET_VERSION=6.3 COV=true
+ - RACKET_VERSION=6.4 COV=true
+ - RACKET_VERSION=6.5 COV=true
+ - RACKET_VERSION=6.6 COV=true
+ - RACKET_VERSION=6.7 COV=true
+ - RACKET_VERSION=6.8 COV=true
+ - RACKET_VERSION=6.9 COV=true
+ - RACKET_VERSION=RELEASE COV=true
+ - RACKET_VERSION=HEAD COV=true
+
+before_install:
+- curl -L https://raw.githubusercontent.com/greghendershott/travis-racket/master/install-racket.sh | bash
+- if $COV; then raco pkg install --deps search-auto doc-coverage cover cover-codecov; fi # or cover-coveralls
+
+install:
+- raco pkg install --deps search-auto -j 2
+
+script:
+- raco test -x -p "$(basename "$TRAVIS_BUILD_DIR")"
+- if $COV; then raco setup --check-pkg-deps --unused-pkg-deps --no-zo --no-launcher --no-install --no-post-install --no-docs --pkgs "$(basename "$TRAVIS_BUILD_DIR")"; fi
+- if $COV; then raco doc-coverage "$(basename "$TRAVIS_BUILD_DIR")"; fi
+- if $COV; then raco cover -s main -s test -s doc -f codecov -f html -d ~/coverage . || true; fi
+# TODO: add an option to cover to run the "outer" module too, not just the submodules.
+# TODO: deploy the coverage info.
+\ No newline at end of file
diff --git a/LICENSE-more.md b/LICENSE-more.md
@@ -0,0 +1,24 @@
+polysemy
+Copyright (c) 2016-2017 Georges Dupéron
+
+
+
+This package is in distributed under the Creative Commons CC0 license
+https://creativecommons.org/publicdomain/zero/1.0/, as specified by
+the LICENSE.txt file.
+
+
+
+The CC0 license is equivalent to a dedication to the Public Domain
+in most countries, but is also effective in countries which do not
+recognize explicit dedications to the Public Domain.
+
+
+
+In order to avoid any potential licensing issues, this package is explicitly
+distributed under the Creative Commons CC0 license
+https://creativecommons.org/publicdomain/zero/1.0/, or under the GNU Lesser
+General Public License (LGPL) https://opensource.org/licenses/LGPL-3.0, or
+under the Apache License Version 2.0
+https://opensource.org/licenses/Apache-2.0, or under the MIT license
+https://opensource.org/licenses/MIT, at your option.
diff --git a/LICENSE.txt b/LICENSE.txt
@@ -0,0 +1,24 @@
+anaphoric
+Copyright (c) 2016-2017 Georges Dupéron
+
+
+
+This package is in distributed under the Creative Commons CC0 license
+https://creativecommons.org/publicdomain/zero/1.0/, as specified by
+the LICENSE.txt file.
+
+
+
+The CC0 license is equivalent to a dedication to the Public Domain
+in most countries, but is also effective in countries which do not
+recognize explicit dedications to the Public Domain.
+
+
+
+In order to avoid any potential licensing issues, this package is explicitly
+distributed under the Creative Commons CC0 license
+https://creativecommons.org/publicdomain/zero/1.0/, or under the GNU Lesser
+General Public License (LGPL) https://opensource.org/licenses/LGPL-3.0, or
+under the Apache License Version 2.0
+https://opensource.org/licenses/Apache-2.0, or under the MIT license
+https://opensource.org/licenses/MIT, at your option.
diff --git a/README.md b/README.md
@@ -0,0 +1,9 @@
+[](https://travis-ci.org/jsmaniac/polysemy)
+[](https://codecov.io/gh/jsmaniac/polysemy)
+[](http://jsmaniac.github.io/travis-stats/#jsmaniac/polysemy)
+[](http://docs.racket-lang.org/polysemy/)
+[](https://github.com/jsmaniac/polysemy/issues)
+[](https://creativecommons.org/publicdomain/zero/1.0/)
+
+polysemy
+========
+\ No newline at end of file
diff --git a/info.rkt b/info.rkt
@@ -0,0 +1,11 @@
+#lang info
+(define collection "polysemy")
+(define deps '("base"
+ "rackunit-lib"))
+(define build-deps '("scribble-lib"
+ "racket-doc"))
+(define scribblings '(("scribblings/polysemy.scrbl" ())))
+(define pkg-desc
+ "Polysemic identifiers, each meaning can be required and renamed separately")
+(define version "0.1")
+(define pkg-authors '("Georges Dupéron"))
diff --git a/main.rkt b/main.rkt
@@ -0,0 +1,157 @@
+#lang racket/base
+
+(provide
+ ;;; Require transformer (does not work correctly, for now)
+ #;poly-in
+ ;; Another require transformer
+ poly-rename-in
+ ;; Alternative require form which handles polysemic ids
+ poly-require
+ ;; Definition of a polysemic id, and of a part of a polysemic id
+ define-poly)
+
+(require racket/match
+ (for-syntax racket/base
+ racket/contract
+ racket/string
+ racket/require-transform
+ syntax/parse))
+
+;; This scope is used to hide and later identify parts of polysemic identifiers.
+;; Each part is stored in a separate identifier.
+(define-for-syntax poly-scope (make-syntax-introducer))
+
+;; Utilities
+;; _____________________________________________________________________________
+
+;; Escapes the identifier, so that it does not contain the separator character
+(begin-for-syntax
+ (define/contract (escape-symbol sym separator escape)
+ (-> symbol? char? char? string?)
+ (let ()
+ (define s1 (symbol->string sym))
+ (define s2 (string-replace s1
+ (format "~a" escape)
+ (format "~a~a" escape escape)))
+ (define s3 (string-replace s1
+ (format "~a" separator)
+ (format "~a~a" separator escape)))
+ s3)))
+
+;; Generates a single-meaning identifier from `id` and `meaning`, possibly
+;; escaping some characters in `meaning` to remove ambiguities.
+(begin-for-syntax
+ (define/contract (gen-id ctx meaning id)
+ (-> syntax? symbol? identifier? identifier?)
+ (let ()
+ (define s (format " polysemy_~a_~a"
+ (escape-symbol meaning #\_ #\\)
+ (symbol->string (syntax-e id))))
+ (datum->syntax ctx (string->symbol s) id id))))
+
+;; Require transformer
+;; _____________________________________________________________________________
+
+;; Require transformer which allows selecting and renaming parts of polysemic
+;; parts of identifiers.
+#;(define-syntax poly-in
+ (make-require-transformer
+ (λ (stx)
+ (syntax-case stx ()
+ [(_ mod id ...)
+ (let ()
+ ;; Works, but we cannot bind a syntax transformer that way.
+ (define idd (syntax-local-lift-expression #'42))
+ ;; Too late, top-level uses of macros have already been prefixed
+ ;; with #%app:
+ (syntax-local-lift-module-end-declaration
+ #'(begin (define-syntax id (λ (stx) #`'(#,stx 42))) ...))
+ ;; Won't work because we have to run expand-import before the
+ ;; module has a chance to be injected:
+ (syntax-local-lift-module
+ #'(module m racket/base
+ (provide id ...)
+ (define-syntax id (λ (stx) #`'(#,stx 42))) ...))
+ (define-values (a b) (expand-import #'(only-in mod id ...)))
+ (define a*
+ (let ([local-id (import-local-id (car a))]
+ [src-sym (import-src-sym (car a))]
+ [src-mod-path (import-src-mod-path (car a))]
+ [mode (import-mode (car a))]
+ [req-mode (import-req-mode (car a))]
+ [orig-mode (import-orig-mode (car a))]
+ [orig-stx (import-orig-stx (car a))])
+ (list (import idd
+ src-sym
+ src-mod-path
+ mode
+ req-mode
+ orig-mode
+ orig-stx))))
+ (values a* b))]))))
+
+(define-syntax poly-rename-in
+ (make-require-transformer
+ (syntax-parser
+ [(_ mod [old-id:id meaning:id new-id:id] ...)
+ (with-syntax ([(old-generated-id ...)
+ (map gen-id
+ (syntax->list #'(old-id ...))
+ (map syntax-e (syntax->list #'(meaning ...)))
+ (syntax->list #'(old-id ...)))]
+ [(new-generated-id ...)
+ (map gen-id
+ (syntax->list #'(new-id ...))
+ (map syntax-e (syntax->list #'(meaning ...)))
+ (syntax->list #'(new-id ...)))])
+ (expand-import
+ #'(rename-in mod [old-generated-id new-generated-id] ...)))])))
+
+;; polysemic require (experiment, nothing interesting for now)
+(define-syntax poly-require
+ (λ (stx)
+ (syntax-case stx ()
+ [(_ mod id ...)
+ (with-syntax ([(tmp ...) (generate-temporaries #'(id ...))])
+ #'(begin
+ (require (only-in mod [id tmp] ...))
+ (define-syntax id (λ (stx) #'42))
+ ...))])))
+
+;; Definition of polysemic identifiers and parts of these
+;; _____________________________________________________________________________
+
+;; Definition of a new polysemic identifier
+(define-syntax (define-poly stx)
+ (syntax-case stx ()
+ [(_ id)
+ #'(define-syntax id (polysemic #'id))]
+ [(_ id meaning value)
+ (with-syntax ([generated-id (gen-id #'id (syntax-e #'meaning) #'id)])
+ #'(define-syntax generated-id value))]))
+
+;; Creates a wrapper for a prop:…, by extracting the the given `meaning`
+;; for the identifier.
+(define-for-syntax ((make-wrapper meaning) self stx)
+ ((syntax-local-value (gen-id (car (syntax-e stx)) meaning (polysemic-id self))) stx))
+
+;; Wrapper for prop:procedure on a transformer id.
+;; Dispatches to
+(define-for-syntax (macro-wrapper self stx)
+ (define id (polysemic-id self))
+ (if (syntax? stx)
+ (syntax-case stx (set!)
+ [x
+ (identifier? #'x)
+ ((syntax-local-value (gen-id #'x 'identifier-macro id)) stx)]
+ [(set! v . _)
+ ((syntax-local-value (gen-id #'v 'set!-macro id)) stx)]
+ [(self . _)
+ ((syntax-local-value (gen-id #'self 'normal-macro id)) stx)])
+ (error "oops")#;((syntax-local-value (gen-id 'normal-macro id)) stx)))
+
+;; Instances of this struct are bound (as transformer values) to polysemic ids.
+(begin-for-syntax
+ (struct polysemic (id)
+ #:property prop:match-expander (make-wrapper 'match-expander)
+ #:property prop:procedure macro-wrapper))
+\ No newline at end of file
diff --git a/scribblings/polysemy.scrbl b/scribblings/polysemy.scrbl
@@ -0,0 +1,9 @@
+#lang scribble/manual
+@(require (for-label racket/base
+ polysemy))
+
+@title{Polysemy: support for polysemic identifiers}
+@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
+
+@defmodule[polysemy]
+
diff --git a/test/test-provide.rkt b/test/test-provide.rkt
@@ -0,0 +1,13 @@
+#lang racket
+
+(require polysemy)
+
+(provide (all-defined-out))
+
+(define-poly foo)
+(define-poly foo identifier-macro (λ (stx) #'"originally foo"))
+
+(define-poly bar)
+(define-poly bar identifier-macro (λ (stx) #'"originally bar"))
+
+(define-poly baz)
+\ No newline at end of file
diff --git a/test/test-require.rkt b/test/test-require.rkt
@@ -0,0 +1,17 @@
+#lang racket
+
+(require polysemy)
+
+;(require (poly-in "test-provide.rkt" foo))
+;(poly-require "test-provide.rkt" foo)
+
+(require (poly-rename-in "test-provide.rkt"
+ [foo identifier-macro baz]
+ [bar identifier-macro foo]))
+
+(define-poly bar identifier-macro (λ (stx) #'"overridden bar"))
+
+foo ;; "originally bar"
+bar ;; "overridden bar"
+baz ;; "originally foo"
+
