#lang scheme/base (require (for-template scheme/base syntax/stx scheme/stxparam "kws.ss") scheme/match scheme/contract scheme/private/sc syntax/stx syntax/boundmap "rep.ss" "util.ss") (provide/contract [parse:rhs (rhs? (listof sattr?) (listof identifier?) . -> . syntax?)] [parse:clauses (syntax? identifier? identifier? . -> . syntax?)]) ;; A PK is (make-pk (listof Pattern) stx) ;; k is the rhs expression: ;; - open term with the attr names as free variables ;; - attr name must be bound to variable of (listof^depth value) ;; - 'fail' stxparameterized to (non-escaping!) failure procedure (define-struct pk (ps k) #:transparent) ;; A FrontierContext (FC) is ({nat id}*) (define (empty-frontier x) (list 0 x)) (define (done-frontier x) (list +inf.0 x)) (define (frontier:add-car fc x) (list* 0 x fc)) (define (frontier:add-cdr fc) (cons (match (car fc) [(? number? n) (add1 n)] [`(+ ,n . ,rest) `(+ ,(add1 n) . ,rest)]) (cdr fc))) (define (frontier:add-index fc expr) (cons (match (car fc) [(? number? n) `(+ ,n ,expr)] [`(+ ,n . ,rest) `(+ ,n ,expr . ,rest)]) (cdr fc))) (define (frontier->expr fc) #`(list #,@(reverse (or fc null)))) ;; A FrontierContext (FC) is (listof (cons id nat)) ;; parse:rhs : RHS (listof SAttr) (listof identifier) -> stx ;; Takes a list of the relevant attrs; order is significant! ;; Returns either fail or a list having length same as 'relsattrs' (define (parse:rhs rhs relsattrs args) (with-syntax ([(arg ...) args]) #`(lambda (x arg ...) (define (fail-rhs x expected reason frontier) (make-failed x expected reason)) #,(parse:pks (list #'x) (list (empty-frontier #'x)) (rhs->pks rhs relsattrs #'x) #'fail-rhs)))) ;; fail : id id #:pattern datum #:reason datum #:fc FC -> stx (define (fail k x #:pattern [p #f] #:reason [reason #f] #:fc [fc #f]) (with-syntax ([k k] [x x] [p p] [reason reason] [fc-expr (frontier->expr fc)]) #`(let ([failcontext fc-expr]) #;(printf "failing at ~s\n" failcontext) (k x 'p 'reason failcontext)))) ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs->pks rhs relsattrs main-var) (match rhs [(struct rhs:union (orig-stx attrs rhss)) (for*/list ([rhs rhss] [pk (rhs->pks rhs relsattrs main-var)]) pk)] [(struct rhs:pattern (orig-stx attrs pattern decls remap sides)) (list (make-pk (list pattern) (expr:convert-sides sides (pattern-attrs pattern) main-var (lambda (iattrs) (expr:sc iattrs relsattrs remap main-var)))))])) (define (expr:convert-sides sides iattrs main-var k) (match sides ['() (k iattrs)] [(cons (struct clause:where (e)) rest) (let* ([k-rest (expr:convert-sides rest iattrs main-var k)]) (with-syntax ([(x) (generate-temporaries #'(x))]) #`(let ([x #,(wrap-pattern-body/attrs iattrs 0 e)]) (if x #,k-rest #,(fail #'enclosing-fail main-var #:reason "side condition failed" #:fc (done-frontier main-var))))))] [(cons (struct clause:with (p e)) rest) (let* ([new-iattrs (append (pattern-attrs p) iattrs)] [k-rest (expr:convert-sides rest new-iattrs main-var k)]) (with-syntax ([(x fail-k) (generate-temporaries #'(x fail-k))]) #`(let ([x #,(wrap-pattern-body/attrs iattrs 0 e)] [fail-k enclosing-fail]) #,(parse:pks (list #'x) (list (done-frontier #'x)) (list (make-pk (list p) k-rest)) #'fail-k))))])) ;; expr:sc : (listof IAttr) (listof SAttr) env stx -> stx (define (expr:sc iattrs relsattrs remap main-var) (let* ([reliattrs (reorder-iattrs relsattrs iattrs remap)] [flat-reliattrs (flatten-attrs* reliattrs)] [relids (map attr-name flat-reliattrs)]) (with-syntax ([main main-var] [(relid ...) relids]) #'(list main relid ...)))) (define (check-literals-list stx) (unless (stx-list? stx) (raise-syntax-error #f "expected list of identifiers" stx)) (for ([id (syntax->list stx)]) (unless (identifier? id) (raise-syntax-error #f "expected identifier" id))) (syntax->list stx)) (define clauses-kw-table (list (list '#:literals check-literals-list))) ;; parse:clauses : stx identifier identifier -> stx (define (parse:clauses stx var failid) (define-values (chunks clauses-stx) (chunk-kw-seq/no-dups stx clauses-kw-table)) (define literals (cond [(assq '#:literals chunks) => caddr] [else null])) (define (clause->pk clause) (syntax-case clause () [(p . rest) (let-values ([(rest decls _ sides) (parse-pattern-directives #'rest #:sc? #f #:literals literals)]) (syntax-case rest () [(b) (let* ([pattern (parse-pattern #'p decls)]) (make-pk (list pattern) (expr:convert-sides sides (pattern-attrs pattern) var (lambda (iattrs) (wrap-pattern-body/attrs iattrs 0 #'b)))))] [_ (raise-syntax-error #f "expected single body expression" clause)]))])) #;(printf "literals: ~s\n" literals) (unless (stx-list? clauses-stx) (raise-syntax-error #f "expected sequence of clauses" clauses-stx)) (parse:pks (list var) (list (empty-frontier var)) (map clause->pk (stx->list clauses-stx)) failid)) ;; An ExtPK is one of ;; - PK ;; - (make-idpks stxclass (listof stx) (listof PK)) ;; - (make-cpks (listof PK) (listof DatumPKS) (listof LiteralPKS)) (define-struct idpks (stxclass args idpks)) (define-struct cpks (pairpks datumpks literalpks)) ;; A DatumPKS is (make-datumpks datum (listof PK)) (define-struct datumpks (datum pks)) ;; A LiteralPKS is (make-literalpks identifier (listof PK)) (define-struct literalpks (literal pks)) ;; parse:pks : (listof identifier) (listof FC) (listof PK) identifier -> stx ;; Each PK has a list of |vars| patterns. ;; The list of PKs must not be empty. (define (parse:pks vars fcs pks failid) (cond [(null? pks) (error 'parse:pks "internal error: empty list of rows")] [(null? vars) ;; Success! (let* ([failvar (car (generate-temporaries #'(fail-k)))] [exprs (for/list ([pk pks]) #`(with-enclosing-fail #,failvar #,(pk-k pk)))]) (with-syntax ([failvar failvar] [(expr ...) exprs]) #`(let-syntax ([failvar (make-rename-transformer (quote-syntax #,failid))]) (try failvar (expr ...)))))] [else (let-values ([(vars extpks) (split-pks vars pks)]) (let* ([failvar (car (generate-temporaries #'(fail-k)))] [exprs (for/list ([extpk extpks]) (parse:extpk vars fcs extpk failvar))]) (with-syntax ([failvar failvar] [(expr ...) exprs]) #`(let-syntax ([failvar (make-rename-transformer (quote-syntax #,failid))]) (try failvar (expr ...))))))])) ;; parse:extpk : (listof identifier) (listof FC) ExtPK identifier -> stx ;; Pre: vars is not empty (define (parse:extpk vars fcs extpk failid) (match extpk [(struct idpks (stxclass args pks)) (with-syntax ([sub-parse-expr (if stxclass #`(#,(sc-parser-name stxclass) #,(car vars) #,@args) #`(list #,(car vars)))] [var0 (car vars)] [(r) (generate-temporaries #'(r))]) #`(let ([r sub-parse-expr]) (if (ok? r) #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'r) failid) #,(fail failid (car vars) #:pattern (and stxclass (sc-name stxclass)) #:fc (car fcs)))))] [(struct cpks (pairpks datumpkss literalpkss)) (with-syntax ([var0 (car vars)] [(dvar0) (generate-temporaries (list (car vars)))]) (with-syntax ([(head-var tail-var) (generate-temporaries #'(head tail))] [(pair-pattern ...) (for*/list ([pk pairpks]) (pattern-orig-stx (car (pk-ps pk))))] [(datum-pattern ...) (for*/list ([datumpk datumpkss] [pk (datumpks-pks datumpk)]) (pattern-orig-stx (car (pk-ps pk))))] [(datum-test ...) (for/list ([datumpk datumpkss]) (let ([datum (datumpks-datum datumpk)]) #`(equal? dvar0 (quote #,datum))))] [(datum-rhs ...) (map (lambda (pks) (parse:pks (cdr vars) (cdr fcs) (shift-pks:datum pks) failid)) (map datumpks-pks datumpkss))] [(lit-test ...) (for/list ([literalpks literalpkss]) (let ([literal (literalpks-literal literalpks)]) #`(and (identifier? var0) (free-identifier=? var0 (quote-syntax #,literal)))))] [(lit-rhs ...) (map (lambda (pks) (parse:pks (cdr vars) (cdr fcs) (shift-pks:literal pks) failid)) (map literalpks-pks literalpkss))]) #`(let ([dvar0 (if (syntax? var0) (syntax-e var0) var0)]) (cond #,@(if (pair? pairpks) #`([(pair? dvar0) (let ([head-var (car dvar0)] [tail-var (cdr dvar0)]) #,(parse:pks (list* #'head-var #'tail-var (cdr vars)) (list* (frontier:add-car (car fcs) #'head-var) (frontier:add-cdr (car fcs)) (cdr fcs)) (shift-pks:pair pairpks) failid))]) #`()) #,@(if (pair? literalpkss) #'([lit-test lit-rhs] ...) #'()) [datum-test datum-rhs] ... [else #,(let ([ps #'(pair-pattern ... datum-pattern ...)]) (with-syntax ([ep (if (= (length (syntax->list ps)) 1) (car (syntax->list ps)) #`(union #,@ps))]) (fail failid (car vars) #:pattern #'ep #:fc (car fcs))))]))))] #; [(struct pk ((cons (struct pat:splice (orig-stx attrs depth head tail)) rest-ps) k)) (let-match ([(struct pat:id-splice (_ head-attrs _ name ssc args)) head]) (let* ([head-flat-attrs (flatten-attrs* head-attrs)] [head-ids (map attr-name head-flat-attrs)]) (with-syntax* ([var0 (car vars)] [(hid ...) head-ids] [(fail-k) (generate-temporaries #'(fail-k))] [ok-k #`(lambda (fail-k hid ...) #,(parse:pks (cons #'t (cdr vars)) fcs ;; FIXME: must update! (cons tail (shift-pks:id pks #'r)) #'fail-k))] [sub-parse-expr #`(#,(ssc-parser-name ssc) #,(car vars) #,@args)]) #'sub-parse-expr)))] [(struct pk ((cons (struct pat:gseq (orig-stx attrs depth heads tail)) rest-ps) k)) (let* ([xvar (car (generate-temporaries (list #'x)))] [head-lengths (for/list ([head heads]) (length (head-ps head)))] [head-attrss (for/list ([head heads]) (flatten-attrs* (head-attrs head)))] [hid-initss (for/list ([head heads] [head-attrs head-attrss]) (for/list ([head-attr head-attrs]) (cond [(head-default head) => (lambda (x) #`(quote-syntax #,x))] [(head-as-list? head) #'null] [else #'#f])))] [combinerss (for/list ([head heads] [head-attrs head-attrss]) (for/list ([head-attr head-attrs]) (if (head-as-list? head) #'cons #'or)))] [finalizess (for/list ([head heads] [head-attrs head-attrss]) (for/list ([head-attr head-attrs]) (if (head-as-list? head) #'reverse #'values)))] [head-idss (for/list ([head-attrs head-attrss]) (map attr-name head-attrs))] [completed-heads (for/list ([head heads]) (complete-heads-pattern head xvar (add1 depth) orig-stx))] [hid-argss (map generate-temporaries head-idss)] [hid-args (apply append hid-argss)] [mins (map head-min heads)] [maxs (map head-max heads)] [as-list?s (map head-as-list? heads)] [reps (generate-temporaries (for/list ([head heads]) 'rep))]) (with-syntax ([x xvar] [var0 (car vars)] [((hid ...) ...) head-idss] [((hid-arg ...) ...) hid-argss] [((hid-init ...) ...) hid-initss] [((combine ...) ...) combinerss] [((finalize ...) ...) finalizess] [(head-length ...) head-lengths] [(rep ...) reps] [(maxrepconstraint ...) ;; FIXME: move to side condition to appropriate pattern (for/list ([repvar reps] [maxrep maxs]) (if maxrep #`(< #,repvar #,maxrep) #`#t))] [(minrepclause ...) (for/list ([repvar reps] [minrep mins] #:when minrep) #`[(< #,repvar #,minrep) #,(fail #'enclosing-fail (car vars) #:reason "minimum repetition constraint failed")])] [(occurs-binding ...) (for/list ([head heads] [rep reps] #:when (head-occurs head)) #`[#,(head-occurs head) (positive? #,rep)])] [(parse-loop failkv fail-tail) (generate-temporaries #'(parse-loop failkv fail-tail))]) (with-syntax ([(rhs ...) #`[(let ([hid-arg (combine hid hid-arg)] ...) (if maxrepconstraint (let ([rep (add1 rep)]) (parse-loop x #,@hid-args #,@reps enclosing-fail)) #,(fail #'enclosing-fail #'var0 #:reason "maxiumum repetition constraint failed"))) ...]] [tail-rhs #`(cond minrepclause ... [else (let ([hid (finalize hid-arg)] ... ... occurs-binding ... [fail-tail enclosing-fail]) #,(parse:pks (cdr vars) (cdr fcs) (list (make-pk rest-ps k)) #'fail-tail))])]) #`(let () (define (calculate-index rep ...) (+ (* rep head-length) ...)) (define (parse-loop x hid-arg ... ... rep ... failkv) #,(parse:pks (list #'x) (list (frontier:add-index (car fcs) #'(calculate-index rep ...))) (append (map make-pk (map list completed-heads) (syntax->list #'(rhs ...))) (list (make-pk (list tail) #`tail-rhs))) #'failkv)) (let ([hid hid-init] ... ... [rep 0] ...) (parse-loop var0 hid ... ... rep ... #,failid))))))])) ;; complete-heads-patterns : Head identifier number stx -> Pattern (define (complete-heads-pattern head rest-var depth seq-orig-stx) (define (loop ps pat) (if (pair? ps) (make-pat:pair (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat)) (append (pattern-attrs (car ps)) (pattern-attrs pat)) depth (car ps) (loop (cdr ps) pat)) pat)) (define base (make-pat:id seq-orig-stx (list (make-attr rest-var depth null)) depth rest-var #f null)) (loop (head-ps head) base)) ;; split-pks : (listof identifier) (listof PK) ;; -> (values (listof identifier) (listof ExtPK) (define (split-pks vars pks) (values vars (if (pair? vars) (split-pks/first-column pks) pks))) ;; split-pks/first-column : (listof PK) -> (listof ExtPK) ;; Pre: the PKs have at least one column (define (split-pks/first-column pks) (define (get-pat x) (car (pk-ps x))) (define (constructor-pat? p) (or (pat:pair? p) (pat:datum? p) (pat:literal? p))) (define (constructor-pk? pk) (constructor-pat? (get-pat pk))) (define (id-pk? pk) (pat:id? (get-pat pk))) (define pk-cache (make-hasheq)) (define pattern-cache (make-hasheq)) (define (commutes? pk1 pk2) (let ([pk1-ht (hash-ref pk-cache pk1 (lambda () (let ([pk1-ht (make-hasheq)]) (hash-set! pk-cache pk1 pk1-ht) pk1-ht)))]) (hash-ref pk1-ht pk2 (lambda () (let ([result (ormap pattern-commutes? (pk-ps pk1) (pk-ps pk2))]) (hash-set! pk1-ht pk2 result) result))))) (define (pattern-commutes? p1 p2) (let ([result (not (pattern-intersects? p1 p2))]) (when result (printf "commutes!\n ~s\n & ~s\n" (syntax->datum (pattern-orig-stx p1)) (syntax->datum (pattern-orig-stx p2)))) result)) (define (pattern-intersects? p1 p2) (let ([p1-ht (hash-ref pattern-cache p1 (lambda () (let ([p1-ht (make-hasheq)]) (hash-set! pattern-cache p1 p1-ht) p1-ht)))]) (hash-ref p1-ht p2 (lambda () (let ([result (do-pattern-intersects? p1 p2)]) (hash-set! p1-ht p2 result) result))))) (define (do-pattern-intersects? p1 p2) (or (pat:id? p1) (pat:id? p2) (and (pat:datum? p1) (pat:datum? p2) (equal? (pat:datum-datum p1) (pat:datum-datum p2))) (and (pat:pair? p1) (pat:pair? p2) (pattern-intersects? (pat:pair-head p1) (pat:pair-head p2)) (pattern-intersects? (pat:pair-tail p1) (pat:pair-tail p2))) ;; FIXME: conservative (and (pat:literal? p1) (pat:literal? p2)) (pat:splice? p1) (pat:splice? p2) (pat:gseq? p1) (pat:gseq? p2))) (define (major-loop pks epks) (match pks ['() (reverse epks)] [(cons (? constructor-pk? head) tail) (let-values ([(r-constructor-pks tail) (gather constructor-pat? tail (list head) null)]) (let ([c-epk (group-constructor-pks r-constructor-pks)]) (major-loop tail (cons c-epk epks))))] [(cons (? id-pk? head) tail) (let* ([this-pat (get-pat head)] [this-stxclass (pat:id-stxclass this-pat)] [this-args (pat:id-args this-pat)]) (let-values ([(r-id-pks tail) (gather (lambda (p) (and (pat:id? p) (equal? (pat:id-stxclass p) this-stxclass) (equal? (pat:id-args p) this-args))) tail (list head) null)]) (let ([id-epk (make idpks this-stxclass this-args (reverse r-id-pks))]) (major-loop tail (cons id-epk epks)))))] [(cons head tail) (major-loop tail (cons head epks))])) ;; gather : (PK -> boolean) (listof PK) (listof PK) (listof PK) ;; -> (listof PK) (listof PK) (define (gather pred pks taken prefix) #;(printf "called gather (~s pks, ~s prefix)\n" (length pks) (length prefix)) (match pks ['() #;(printf "took ~s, left ~s\n" (length taken) (length prefix)) (values taken (reverse prefix))] [(cons pk tail) ;; We can have it if it can move past everything in the prefix. (if (and (pred (get-pat pk)) (for/and ([prefixpk prefix]) (commutes? pk prefixpk))) (gather pred tail (cons pk taken) prefix) (gather pred tail taken (cons pk prefix)))])) ;; group-constructor-pks : (listof PK) -> ExtPK (define (group-constructor-pks reversed-pks) (define pairpks null) (define ht (make-hash)) (define lit-ht (make-bound-identifier-mapping)) (for ([pk reversed-pks]) (let ([p (get-pat pk)]) (cond [(pat:pair? p) (set! pairpks (cons pk pairpks))] [(pat:datum? p) (let ([d (pat:datum-datum p)]) (hash-set! ht d (cons pk (hash-ref ht d null))))] [(pat:literal? p) (let ([lit (pat:literal-literal p)]) (bound-identifier-mapping-put! lit-ht lit (cons pk (bound-identifier-mapping-get lit-ht lit (lambda () null)))))]))) (let ([datumpkss (hash-map ht make-datumpks)] [litpkss (bound-identifier-mapping-map lit-ht make-literalpks)]) (make cpks pairpks datumpkss litpkss))) (major-loop pks null)) ;; shift-pks:id : (listof PK) identifier -> (listof PK) (define (shift-pks:id pks matches-var) (map (lambda (pk) (shift-pk:id pk matches-var)) pks)) ;; shift-pk:id : PK identifier identifier -> PK ;; FIXME: Assumes that all attrs are relevant!!! (define (shift-pk:id pk0 matches-var0) (match pk0 [(struct pk ((cons (struct pat:id (_ attrs depth name _ _)) rest-ps) k)) (let* ([flat-attrs (flatten-attrs* attrs depth #f #f)] ;; FIXME: depth already included, right??? [ids (map attr-name flat-attrs)] [depths (map attr-depth flat-attrs)]) (with-syntax ([(id ...) ids] [(depth ...) depths]) (make-pk rest-ps (if (pair? ids) #`(let-values ([(id ...) #,(if name #`(apply values #,matches-var0) #`(apply values (cdr #,matches-var0)))]) #,k) k))))])) ;; shift-pks:datum : (listof PK) -> (listof PK) (define (shift-pks:datum pks) (define (shift-pk pk) (make-pk (cdr (pk-ps pk)) (pk-k pk))) (map shift-pk pks)) ;; shift-pks:literal : (listof PK) -> (listof PK) (define (shift-pks:literal pks) (define (shift-pk pk) (make-pk (cdr (pk-ps pk)) (pk-k pk))) (map shift-pk pks)) ;; shift-pks:pair : (listof PK) -> (listof PK) (define (shift-pks:pair pks) (define (shift-pk pk0) (match pk0 [(struct pk ((cons (struct pat:pair (orig-stx attrs depth head tail)) rest-ps) k)) (make-pk (list* head tail rest-ps) k)])) (map shift-pk pks)) ;; wrap-pattern-body : (listof IAttr) nat stx -> stx (define (wrap-pattern-body/attrs iattrs depth b) (let* ([flat-iattrs (flatten-attrs* iattrs depth #f #f)] [ids (map attr-name flat-iattrs)] [depths (map attr-depth flat-iattrs)]) (with-syntax ([(id ...) ids] [(depth ...) depths] [b b]) #`(let-syntax ([id (make-syntax-mapping 'depth (quote-syntax id))] ...) b))))