Permalink
Browse files

Added racket/utils.rkt.

  • Loading branch information...
1 parent 0e3d6a0 commit afc713bef0163beec417d66905b34a490492e80f @rocketnia committed Mar 11, 2011
Showing with 331 additions and 4 deletions.
  1. +1 −1 LICENSE.txt
  2. +23 −3 README
  3. +46 −0 racket/utils-part-1.rkt
  4. +139 −0 racket/utils-part-2.rkt
  5. +122 −0 racket/utils.rkt
View
@@ -1,4 +1,4 @@
-This software is copyright (c) Ross Angle 2010.
+This software is copyright (c) Ross Angle 2010, 2011.
Permission to use this software is granted under the Perl Foundation's
Artistic License 2.0.
View
26 README
@@ -45,10 +45,12 @@ things.
The code in the arc/ directory is targeted mainly at Arc 3.1, which
you can download at http://ycombinator.com/arc/arc3.1.tar. Arc 3.1
-itself depends on MzScheme. For more detailed help setting up Arc 3.1,
+itself depends on Racket, which you can get from
+http://racket-lang.org/. For more detailed help setting up Arc 3.1,
including how to adjust it to work on Windows, http://arclanguage.org/
is a good resource. If you're just getting started with Arc,
-http://awwx.ws/ lists some other helpful links.
+http://awwx.ws/ and http://sites.google.com/site/arclanguagewiki/ list
+some other helpful links.
Besides the official Arc 3.1 implementation, three other Arc setups
are supported: The Anarki fork (http://github.com/nex3/arc) and the
@@ -112,6 +114,24 @@ modules look like once you've looked at the source of a few of the
modules included with Lathe.
+== Setup in Racket ==
+
+Racket is a bit easier to set up. It already has a module system, so
+you can import a Lathe module like so:
+
+ (require "your/path/to/lathe/racket/utils.rkt")
+
+In fact, utils.rkt is all the Racket support there is for now. It's
+not especially exciting, either; PLaneT has two or three other,
+significantly more well-developed utility libraries, and I don't have
+any frameworks to set me apart from the crowd. In fact, what I do have
+largely disregards or works against frameworks that are already built
+into Racket! Use it at your own peril, or figure out some way to use
+Arc in your Racket program instead.
+
+
+== Afterword ==
+
Thanks a lot for considering Lathe, and I hope it helps you out!
-2010 Ross Angle
+2010, 2011 Ross Angle
View
@@ -0,0 +1,46 @@
+; utils-part-1.arc
+;
+; Miscellaneous utilities, part 1.
+;
+; This is in several parts so that certain utilities can be used in
+; the transformation phases of other utilities.
+
+#lang racket
+(provide (all-defined-out))
+
+
+(define (idfn result)
+ result)
+
+(define voidval (void))
+
+(define-syntax-rule (fn parms body ...)
+ (lambda parms
+ voidval
+ body ...))
+
+
+; This is based on a strategy introduced at or around
+; <http://arclanguage.org/item?id=13584>. An alternate strategy is at
+; <http://arclanguage.org/item?id=12916>.
+
+(define (fn-as-non-syntax syntax body)
+ (if (syntax? syntax)
+ (let ([result (body (syntax-e syntax))])
+ (if (syntax? result)
+ result
+ (datum->syntax syntax result syntax)))
+ (body syntax)))
+
+(define-syntax-rule (as-non-syntax var syntax body ...)
+ (fn-as-non-syntax syntax (fn (var) body ...)))
+
+
+(define-syntax ifs
+ (syntax-rules ()
+ [ (ifs)
+ voidval]
+ [ (ifs else)
+ else]
+ [ (ifs condition then elses ...)
+ (if condition then (ifs elses ...))]))
View
@@ -0,0 +1,139 @@
+; utils-part-2.arc
+;
+; Miscellaneous utilities, part 2.
+;
+; This is in several parts so that certain utilities can be used in
+; the transformation phases of other utilities.
+
+#lang racket
+(require "utils-part-1.rkt")
+(require (for-syntax "utils-part-1.rkt"))
+(provide (all-from-out "utils-part-1.rkt"))
+(provide (all-defined-out))
+
+(define (non-syntax syntax)
+ (if (syntax? syntax)
+ (syntax-e syntax)
+ syntax))
+
+; This is based on <http://arclanguage.org/item?id=13450>, but it
+; isn't based on the refined idea at
+; <http://arclanguage.org/item?id=13888> of a reader macro.
+;
+; TODO: See if it's actually helpful in the long run.
+;
+(define-syntax (: stx)
+ (let loop ([stx (fn-as-non-syntax stx cdr)])
+ (as-non-syntax stx stx
+ (ifs (null? stx)
+ stx
+ (eqv? ': (syntax-e (car stx)))
+ (list (loop (cdr stx)))
+ (cons (car stx) (loop (cdr stx)))))))
+
+
+(define-syntax-rule (each var seq body ...)
+ (for-each (fn (var) body ...) seq))
+
+(define-syntax-rule (maplet var seq body ...)
+ (map (fn (var) body ...) seq))
+
+
+(define-syntax-rule (thunk body ...)
+ (fn () body ...))
+
+(define (has-first? seq)
+ (: cons? : non-syntax seq))
+
+(define (empty? seq)
+ (: null? : non-syntax seq))
+
+(define (listish? x)
+ (or (null? x) (pair? x)))
+
+(define (seq? x)
+ (or (empty? x) (has-first? x)))
+
+
+(define (like-syntax model imitator)
+ (if (syntax? model)
+ (datum->syntax model imitator model)
+ imitator))
+
+
+(define (fn-iffirst-lenient seq then else)
+ (if (: pair? : non-syntax seq)
+ (then (: car : non-syntax seq) (fn-as-non-syntax seq cdr))
+ (else)))
+
+(define-syntax-rule (iffirst-lenient first rest seq then elses ...)
+ (fn-iffirst-lenient seq (fn (first rest) then)
+ (: thunk : ifs elses ...)))
+
+(define (fn-iffirst seq then [else error] [fail error])
+ (iffirst-lenient first rest seq
+ (then first rest)
+ (empty? seq)
+ (else)
+ (fail)))
+
+(define-syntax-rule (letfirst first rest seq then ...)
+ (fn-iffirst seq (fn (first rest) then ...)))
+
+(define-syntax-rule (iffirst first rest seq then elses ...)
+ (fn-iffirst seq (fn (first rest) then) (: thunk : ifs elses ...)))
+
+(define-syntax-rule (iffirst-fail first rest seq then else fail)
+ (fn-iffirst seq (fn (first rest) then) (thunk else) (thunk fail)))
+
+; This was introduced at <http://arclanguage.org/item?id=13407>.
+(define-syntax delisting
+ (syntax-rules ()
+ [ (delisting rest seq)
+ (let ([rest seq])
+ voidval)]
+ [ (delisting rest seq default)
+ (let ([rest seq])
+ default)]
+ [ (delisting rest seq then nextvar defaults ...)
+ (let ([rest seq])
+ (iffirst-lenient nextvar our-rest rest
+ (delisting rest our-rest
+ defaults ...)
+ then))]))
+
+(define (rev seq [end null])
+ (as-non-syntax seq seq
+ (iffirst first rest seq
+ (: rev rest : cons first end)
+ end)))
+
+(define (tuples n seq [pairerr #f])
+ (unless (0 . < . n)
+ (error))
+ (as-non-syntax seq seq
+ (let loop ([seq seq] [rev-result null] [rev-tuple null] [i 0])
+ (iffirst-fail first rest seq
+ (if (<= n i)
+ (loop rest (cons (rev rev-tuple) rev-result) (list first) 0)
+ (loop rest rev-result (cons first rev-tuple) (add1 i)))
+ (: rev : cons (rev rev-tuple) rev-result)
+ (if pairerr
+ (raise pairerr)
+ (: rev : cons (rev rev-tuple seq) rev-result))))))
+
+(define (pair seq [pairerr #f])
+ (tuples 2 seq pairerr))
+
+(define (parse-magic-withlike body [pairerr #f])
+ (: as-non-syntax body body : delisting rest body
+ (cons null body)
+ first (if (has-first? first)
+ (cons (pair first pairerr) rest)
+ (let loop ([rev-binds null] [body body])
+ (delisting rest body
+ (cons (rev rev-binds) body)
+ var (cons (rev rev-binds) body)
+ val (if (: symbol? : non-syntax var)
+ (loop (cons (list var val) rev-binds) rest)
+ (cons (rev rev-binds) body)))))))
View
@@ -0,0 +1,122 @@
+; utils.arc
+;
+; Miscellaneous utilities, final part.
+;
+; This is in several parts so that certain utilities can be used in
+; the transformation phases of other utilities.
+
+#lang racket
+(require racket/stxparam)
+(require "utils-part-2.rkt")
+(require (for-syntax "utils-part-2.rkt"))
+(provide (all-from-out "utils-part-2.rkt"))
+(provide (all-defined-out))
+
+(define-syntax-rule (zap! func place args ...)
+ (set! place (func place args ...)))
+
+(define-syntax (w- stx)
+ (as-non-syntax stx (fn-as-non-syntax stx cdr)
+ (delisting body stx
+ voidval
+ var var
+ val (if (: symbol? : non-syntax var)
+ #`(: let ([#,var #,val]) : w- #,@body)
+ #`(: begin #,var : w- #,val #,@body)))))
+
+; NOTE: Racket already has something named 'do, and 'begin is too
+; verbose.
+(define-syntax-rule (du body ...)
+ (begin voidval body ...))
+
+(define-syntax-rule (du1 val body ...)
+ (begin0 val voidval body ...))
+
+(define-syntax-rule (ret var val body ...)
+ (w- (var val)
+ body ...
+ var))
+
+(define-syntax-rule (accum var body ...)
+ (ret result null
+ (w- (var (fn (elem) (push! elem result)))
+ body ...)))
+
+(define-syntax (namedlet stx)
+ (: as-non-syntax stx stx : delisting binds-and-body stx
+ (error)
+ _ (error)
+ next (letfirst binds body (parse-magic-withlike binds-and-body)
+ #`(let #,next #,binds #,@body))))
+
+(define-syntax (magic-withlike stx)
+ (: as-non-syntax stx stx : delisting binds-and-body stx
+ (error)
+ _ (error)
+ op (letfirst binds body (parse-magic-withlike binds-and-body)
+ #`(#,op #,binds
+ voidval
+ #,@body))))
+
+(define-syntax-rule (=fn var parms body ...)
+ (set! var (fn parms body ...)))
+
+(define-syntax-rule (named name body ...)
+ (letrec ([name (du body ...)])
+ name))
+
+(define-syntax-rule (rfn name parms body ...)
+ (named name (fn parms body ...)))
+
+(define-syntax-rule (letr binds-and-body ...)
+ (magic-withlike letrec binds-and-body ...))
+
+
+; This is inspired by <http://blog.racket-lang.org/2008/02/
+; dirty-looking-hygiene.html>.
+
+(define-syntax-rule (w-stxparam binds-and-body ...)
+ (magic-withlike syntax-parameterize binds-and-body ...))
+
+(define-syntax-rule (longhand-w-anaphor
+ ([name transformer] ...) body ...)
+ (syntax-parameterize
+ ([name (make-rename-transformer #'transformer)] ...)
+ body ...))
+
+(define-syntax-rule (w-anaphor binds-and-body ...)
+ (magic-withlike longhand-w-anaphor binds-and-body ...))
+
+(define-syntax-parameter a idfn)
+(define-syntax-parameter b idfn)
+
+(define-syntax-rule (abfn body ...)
+ (lambda (our-a our-b)
+ (w-anaphor (a our-a b our-b)
+ body ...)))
+
+(define-syntax-parameter it idfn)
+
+(define-syntax-rule (zapit! place body ...)
+ (w- our-it place
+ (w-anaphor it our-it
+ (set! place (begin body ...)))))
+
+(define-syntax-parameter next idfn)
+
+(define-syntax-rule (longhand-nextlet binds body ...)
+ (let our-next binds
+ (w-anaphor (next our-next)
+ body ...)))
+
+(define-syntax-rule (nextlet binds-and-body ...)
+ (magic-withlike longhand-nextlet binds-and-body ...))
+
+(define-syntax-rule (nextfn parms body ...)
+ (named our-next
+ (w-anaphor next our-next
+ (fn parms body ...))))
+
+
+(define-syntax-rule (push! elem seq)
+ (zapit! seq (cons elem it)))

0 comments on commit afc713b

Please sign in to comment.