diff --git a/cur-lib/cur/stdlib/list.rkt b/cur-lib/cur/stdlib/list.rkt index b61c2d3..1b1514f 100644 --- a/cur-lib/cur/stdlib/list.rkt +++ b/cur-lib/cur/stdlib/list.rkt @@ -16,7 +16,7 @@ (define (list-ref (A : Type) (ls : (List A))) (match ls - [nil (lambda (n : Nat) (none A))] + [(nil (A : Type)) (lambda (n : Nat) (none A))] [(cons (A : Type) (a : A) (rest : (List A))) (lambda (n : Nat) (match n diff --git a/cur-lib/cur/stdlib/prop.rkt b/cur-lib/cur/stdlib/prop.rkt index 38c28da..ff55f6b 100644 --- a/cur-lib/cur/stdlib/prop.rkt +++ b/cur-lib/cur/stdlib/prop.rkt @@ -40,28 +40,25 @@ (define pf:and-is-symmetric (lambda (P : Type) (Q : Type) (ab : (And P Q)) - (case* And Type ab (P Q) - (lambda (P : Type) (Q : Type) (ab : (And P Q)) - (And Q P)) - ((conj (P : Type) (Q : Type) (x : P) (y : Q)) IH: () (conj/i y x))))) + (match ab + [(conj (P : Type) (Q : Type) (x : P) (y : Q)) + (conj/i y x)]))) (define thm:proj1 (forall (A : Type) (B : Type) (c : (And A B)) A)) (define pf:proj1 (lambda (A : Type) (B : Type) (c : (And A B)) - (case* And Type c (A B) - (lambda (A : Type) (B : Type) (c : (And A B)) A) - ((conj (A : Type) (B : Type) (a : A) (b : B)) IH: () a)))) + (match c + [(conj (A : Type) (B : Type) (a : A) (b : B)) a]))) (define thm:proj2 (forall (A : Type) (B : Type) (c : (And A B)) B)) (define pf:proj2 (lambda (A : Type) (B : Type) (c : (And A B)) - (case* And Type c (A B) - (lambda (A : Type) (B : Type) (c : (And A B)) B) - ((conj (A : Type) (B : Type) (a : A) (b : B)) IH: () b)))) + (match c + [(conj (A : Type) (B : Type) (a : A) (b : B)) b]))) #| TODO: Disabled until #22 fixed (data Or : (forall* (A : Type) (B : Type) Type) diff --git a/cur-lib/cur/stdlib/sugar.rkt b/cur-lib/cur/stdlib/sugar.rkt index 4ac03cc..f16b166 100644 --- a/cur-lib/cur/stdlib/sugar.rkt +++ b/cur-lib/cur/stdlib/sugar.rkt @@ -150,9 +150,25 @@ [(_ D U e (p ...) P clause* ...) #`(elim D U P #,@(map rewrite-clause (syntax->list #'(clause* ...))) p ... e)])) +;; Quite fragie to give a syntactic treatment of pattern matching -> eliminator. Replace with "Elimination with a Motive" (begin-for-syntax (define ih-dict (make-hash)) + (define-syntax-class curried-application + (pattern + ((~literal real-app) name:id e:expr) + #:attr args + (list #'e)) + + (pattern + ((~literal real-app) a:curried-application e:expr) + #:attr name #'a.name + #:attr args + ;; TODO BUG: repeated appends are not performant; cons then reverse in inductive-type-declaration + (append + (attribute a.args) + (list #'e)))) + (define-syntax-class inductive-type-declaration (pattern x:id @@ -161,21 +177,24 @@ #:attr indices '() #:attr decls - (list #`(#,(gensym 'anon-discriminant) : x))) + (list #`(#,(gensym 'anon-discriminant) : x)) + #:attr abstract-indices + values) (pattern - ;; For some reason app is made explicit here - ((~optional (~literal real-app)) x:id e:expr ...+) + ;; BUG TODO NB: Because the inductive type may have been inferred, it may appear in Curnel syntax, i.e., nested applications starting with dep-app + ;; Best to ensure it *always* is in Curnel form, and pattern match on that. + a:curried-application #:attr inductive-name - #'x + (attribute a.name) #:attr indices - (attribute e) + (attribute a.args) #:attr names - (for/list ([e (attribute e)]) + (for/list ([e (attribute indices)]) (format-id e "~a" (gensym 'anon-index))) #:attr types ;; TODO: Detect failure, report error/suggestions - (for/list ([e (attribute e)]) + (for/list ([e (attribute indices)]) (or (type-infer/syn e) (raise-syntax-error 'match @@ -187,13 +206,25 @@ (append (for/list ([name (attribute names)] [type (attribute types)] - [src (attribute e)]) + [src (attribute indices)]) (quasisyntax/loc src (#,name : #,type))) - ;; TODO: quasisyntax/loc (list - (quasisyntax/loc #'x - (#,(gensym 'anon-discriminant) : (x #,@(attribute names)))))))) + (quasisyntax/loc #'a + (#,(gensym 'anon-discriminant) : (inductive-name #,@(attribute names)))))) + #:attr abstract-indices + (lambda (return) + ;; NB: unhygenic + ;; Normalize at compile-time, for efficiency at run-time + (normalize/syn + #`((lambda + ;; TODO: utteraly fragile; relines on the indices being referred to by name, not computed + ;; works only for simple type familes and simply matches on them + #,@(for/list ([name (attribute indices)] + [type (attribute types)]) + #`(#,name : #,type)) + #,return) + #,@(attribute names)))))) ;; todo: Support just names, inferring types (define-syntax-class match-declaration @@ -243,9 +274,10 @@ ;; NB: Non-hygenic ;; BUG TODO: This fails when D is an inductive applied to arguments... #:when (cur-equal? type-syn D)) - (define/syntax-parse type:inductive-type-declaration type-syn) + (define/syntax-parse type:inductive-type-declaration (cur-expand type-syn)) (let ([ih-name (quasisyntax/loc src #,(format-id name-syn "ih-~a" name-syn))] - [ih-type #`(#,motive #,@(attribute type.indices) #,name-syn)]) + ;; Normalize at compile-time, for efficiency at run-time + [ih-type (normalize/syn #`(#,motive #,@(attribute type.indices) #,name-syn))]) (dict-set! ih-dict (syntax->datum name-syn) ih-name) (append decls (list #`(#,ih-name : #,ih-type))))))) @@ -288,18 +320,20 @@ (define-syntax (match syn) (syntax-parse syn - [(_ d:expr + [(_ d + ~! (~optional - (~seq #:in t) + (~seq #:in ~! t) #:defaults ([t (or (type-infer/syn #'d) (raise-syntax-error 'match "Could not infer discrimnant's type. Try using #:in to declare it." syn))])) - (~parse D:inductive-type-declaration (attribute t)) - (~optional (~seq #:return maybe-return-type:expr)) + (~optional (~seq #:return ~! maybe-return-type)) (~peek (~seq (~var prec (match-preclause (attribute maybe-return-type))) ...)) + ~! + (~parse D:inductive-type-declaration (cur-expand (attribute t))) (~bind (return-type (ormap values (attribute prec.return-type)))) (~do (unless (attribute return-type) (raise-syntax-error @@ -307,9 +341,12 @@ "Could not infer return type. Try using #:return to declare it." syn))) ;; BUG TODO: return-type is inferred with the indexes of the branches, but those must be abstracted in the motive... + ;; Replace each of the D.indicies with the equivalent name from D.decls (~bind (motive (quasisyntax/loc syn - (lambda #,@(attribute D.decls) return-type)))) + (lambda #,@(attribute D.decls) + #,((attribute D.abstract-indices) (attribute return-type)))))) (~var c (match-clause (attribute D) (attribute motive))) ...) + ;; TODO: Make all syntax extensions type check, report good error, rather than fail at Curnel (quasisyntax/loc syn (elim D.inductive-name