Initial commit

.gitignore

@@ -0,0 +1,6 @@
+*~
+\#*
+.\#*
+.DS_Store
+compiled/
+/doc/

.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.

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.

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.

README.md

@@ -0,0 +1,9 @@
+[![Build Status,](https://img.shields.io/travis/jsmaniac/polysemy/master.svg)](https://travis-ci.org/jsmaniac/polysemy)
+[![Coverage Status,](https://img.shields.io/codecov/c/github/jsmaniac/polysemy/master.svg)](https://codecov.io/gh/jsmaniac/polysemy)
+[![Build Stats,](https://img.shields.io/badge/build-stats-blue.svg)](http://jsmaniac.github.io/travis-stats/#jsmaniac/polysemy)
+[![Online Documentation,](https://img.shields.io/badge/docs-online-blue.svg)](http://docs.racket-lang.org/polysemy/)
+[![Maintained as of 2017,](https://img.shields.io/maintenance/yes/2017.svg)](https://github.com/jsmaniac/polysemy/issues)
+[![License: CC0 v1.0.](https://img.shields.io/badge/license-CC0-blue.svg)](https://creativecommons.org/publicdomain/zero/1.0/)
+
+polysemy
+========

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"))

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))

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]
+

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)

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"
+