Nearly finished dotlang.

This commit is contained in:
Georges Dupéron 2016-01-21 18:50:12 +01:00
parent b8f8297f83
commit f8edadc1a8
4 changed files with 60 additions and 14 deletions

View File

@ -0,0 +1,27 @@
#lang s-exp "graph/dotlang.rkt"
(require "graph/graph4.lp2.rkt")
(require "graph/map4.rkt")
(require (submod "graph/graph3.lp2.rkt" test))
(require "type-expander/type-expander.lp2.rkt")
(require "graph/structure.lp2.rkt")
(require "graph/variant.lp2.rkt")
(require "lib/low.rkt")
#|
.aa.bb..cc.d
…aa...bb..cc.d
…aa.….bb..cc.d
.aa.….bb..cc.d
(newline)
aa.bb..cc.d
aa...bb..cc.d
aa…bb..cc.d
aa.….bb..cc.d
(newline)
…aa.…bb..cc.d ;; TODO: should cause error
…aa….bb..cc.d ;; TODO: should cause error
|#
g.streets…houses…owner.name
(map: (curry map (λget owner name)) g.streets…houses)

View File

@ -2,25 +2,44 @@
(module dotlang racket
(require typed/racket)
(provide (except-out (all-from-out typed/racket) #%top)
(rename-out [new-#%top #%top]))
(require (for-syntax racket/string))
(require "graph4.lp2.rkt"
"../lib/low-untyped.rkt"
(for-syntax racket/string
syntax/parse
racket/syntax
"../lib/low-untyped.rkt"))
(define-syntax-rule (dot . xyz)
'(dot . xyz))
(define-syntax/parse (dot x:id)
(let* ([str (symbol->string (syntax-e #'x))]
[components (regexp-match* #px"([^.…]|\\.\\.+)+|…" str)]
[unescaped (map (λ (m) (regexp-replace* #px"\\.(\\.+)" m "\\1"))
components)]
[identifiers (map (λ (u) (datum->syntax #'x (string->symbol u)))
unescaped)]
[leading-dot? (regexp-match #px"^(\\.|…)" str)]
[trailing-dot? (regexp-match #px"\\.$" str)])
(define/with-syntax (id ) identifiers)
(cond
[leading-dot? #'(λget id )]
[trailing-dot? (raise-syntax-error 'dot "Found trailing dot" #'x)]
[else #'(get id )])))
(define-syntax (new-#%top stx)
(syntax-case stx ()
[(_ . x)
(let ([components (string-split (symbol->string (syntax->datum #'x))
".")])
(if (> (length components) 1)
#`(dot . #,components)
#'(#%top . x)))])))
(if (regexp-match #rx"\\." (symbol->string (syntax-e #'x)))
#`(dot x)
#'(#%top . x))])))
(module test (submod ".." dotlang)
(require typed/rackunit)
(let ((foo.bar 42))
(check-equal? foo.bar 42))
(check-equal? foo.bar '(dot "foo" "bar")))
(require 'dotlang)
(provide (all-from-out 'dotlang))
#;(module test (submod ".." dotlang)
(require typed/rackunit)
(let ((foo.bar 42))
(check-equal? foo.bar 42))
(check-equal? foo.bar '(dot "foo" "bar")))

View File

@ -2,7 +2,6 @@
(module test typed/racket
(require (submod "graph3.lp2.rkt" test))
(require "graph3.lp2.rkt")
(require "graph4.lp2.rkt")
(require "map4.rkt")
(require "structure.lp2.rkt")

View File

@ -1,6 +1,7 @@
#lang typed/racket
(require (submod "graph/test-map4-get.rkt" test))
(require "__DEBUG_dotlang.rkt")
(require "type-expander/type-expander.lp2.rkt")
(require "type-expander/multi-id.lp2.rkt")