Added docs to functions as the 'doc' field, and added keys builtin

- Propagated docs change through lams in desugar/typecheck/compile
- Extracted keys helper for sealing stuff
- Refactored fun parser return type and typarams to have less matches

src/TODO

@@ -75,6 +75,9 @@ Cleanup:
     !(display (current-namespace))!
   - wrapping where possible?
 
+Invariants
+[] Make objects retain order w.r.t syntax of literal and update
+
 TODO templates:
 
   Adding a new piece of syntax:

src/lang/ast.rkt

@@ -82,6 +82,7 @@ these metadata purposes.
     (params : (Listof Symbol))
     (args : (Listof s-bind))
     (ann : Ann)
+    (doc : String)
     (body : s-block))
    #:transparent)
 (struct: s-def ((syntax : srcloc)
@@ -107,6 +108,7 @@ these metadata purposes.
     (typarams : (Listof Symbol))
     (args : (Listof s-bind))
     (ann : Ann)
+    (doc : String)
     (body : s-block))
    #:transparent)
 
@@ -231,3 +233,4 @@ these metadata purposes.
     (name : Symbol)
     (parameters : (Listof Ann)))
    #:transparent)
+

src/lang/compile.rkt

@@ -51,11 +51,11 @@
     [(s-bool l b) #`(p:mk-bool #,(d->stx b l))]
     [(s-str l s) #`(p:mk-str #,(d->stx s l))]
 
-    [(s-lam l params args ann body)
+    [(s-lam l params args ann doc body)
      (attach l
        (with-syntax ([(arg ...) (d->stx (map s-bind-id args) l)]
                      [body-stx (compile-pyret body)])
-         #`(p:mk-fun (r:λ (arg ...) body-stx))))]
+         #`(p:mk-fun (r:λ (arg ...) body-stx) #,doc)))]
 
     [(s-method l args body)
      (attach l

src/lang/desugar.rkt

@@ -20,6 +20,11 @@
     (s-fun s (make-checker-name name) (list) 
            (list (s-bind s 'specimen (a-any)))
            (a-blank)
+           (format
+            "~a: This function checks that its argument is an
+             instance of the ~a type."
+            (symbol->string (make-checker-name name))
+            (symbol->string name))
            (s-block s
                     (list
                      (s-app s (s-dot s brander 'check)
@@ -59,6 +64,10 @@
                     (list)
                     constructor-args
                     (a-blank)
+                    (format
+                     "~a: Creates an instance of ~a"
+                     (symbol->string name)
+                     (symbol->string name))
                     (s-block s
                      (list
                       (apply-brand s super-brand
@@ -96,19 +105,19 @@
                    (variant-defs/list brander-name super-fields variants))))]
     [(s-do s fun args)
      (define (functionize b)
-       (s-lam s (list) (list) (a-blank) (ds b)))
+       (s-lam s (list) (list) (a-blank) "" (ds b)))
      (s-app s fun (map functionize args))]
 
     [(s-def s name val)
      (s-def s name (ds val))]
 
-    [(s-fun s name typarams args ann body)
+    [(s-fun s name typarams args ann doc body)
      (s-def s
             (s-bind s name (a-arrow s (map s-bind-ann args) ann))
-            (s-lam s typarams args ann (ds body)))]
+            (s-lam s typarams args ann doc (ds body)))]
 
-    [(s-lam s typarams args ann body)
-     (s-lam s typarams args ann (ds body))]
+    [(s-lam s typarams args ann doc body)
+     (s-lam s typarams args ann doc (ds body))]
 
     [(s-method s args body)
      (s-method s args (ds body))]
@@ -166,7 +175,7 @@
             (s-block s (append stmts (list (s-app s (s-id s '%provide) (list)))))])]))
   (match hd
     [(s-provide s exp)
-      (s-fun s '%provide (list) (list) (a-blank) (s-block s (list exp)))]
+      (s-fun s '%provide (list) (list) (a-blank) "" (s-block s (list exp)))]
     [(s-import s file name)
      (define full-path (path->complete-path file))
      (define-values (base relative-file root?) (split-path full-path))

src/lang/grammar.rkt

@@ -44,9 +44,11 @@ fun-body: block "end"
 fun-ty-param-elt: NAME
 fun-ty-param: fun-ty-param-elt ","
 fun-ty-params:
-  "(" fun-ty-param* fun-ty-param-elt ")"
+  ["(" fun-ty-param* fun-ty-param-elt ")"]
 
-fun-header: [fun-ty-params] NAME args ["->" ann]
+return-ann: ["->" ann]
+
+fun-header: fun-ty-params NAME args return-ann
 
 fun-expr: "fun" fun-header ":" fun-body
 

src/lang/parser.rkt

@@ -151,36 +151,42 @@
 
 (define-syntax (fun-ty-params stx)
   (syntax-case stx (fun-ty-param fun-ty-param-elt)
+    [(_) #'(list)]
     [(_ "(" (fun-ty-param
 	     (fun-ty-param-elt param) ",") ...
 	     (fun-ty-param-elt last) ")")
      #`(quote #,(parse-names #'(param ... last)))]))
 
-(define-syntax (fun-expr stx)
+(define-syntax (return-ann stx)
   (syntax-case stx ()
-    [(_ "fun" (fun-header fun-name args) ":" body )
-      (with-syntax ([f-id (parse-id #'fun-name)])
-        #`(s-fun #,(loc stx) 'f-id (list) args (a-blank) body))]
-    [(_ "fun" (fun-header fun-name args "->" ann) ":" body)
-      (with-syntax ([f-id (parse-id #'fun-name)])
-        #`(s-fun #,(loc stx) 'f-id (list) args ann body))]
-    [(_ "fun" (fun-header params fun-name args) ":" body)
-      (with-syntax ([f-id (parse-id #'fun-name)])
-        #`(s-fun #,(loc stx) 'f-id params args (a-blank) body))]
-    [(_ "fun" (fun-header params fun-name args "->" ann) ":" body)
-      (with-syntax ([f-id (parse-id #'fun-name)])
-        #`(s-fun #,(loc stx) 'f-id params args ann body))]))
+    [(_) #'(a-blank)]
+    [(_ "->" ann) #'ann]))
+
+(define-syntax (fun-expr stx)
+  (syntax-case stx (block stmt expr prim-expr string-expr)
+    [(_ "fun" (fun-header params fun-name args return) ":"
+        (fun-body (block (stmt (expr (prim-expr (string-expr s))))
+                         stmt2
+                         stmts ...)
+                  "end"))
+     (with-syntax ([f-id (parse-id #'fun-name)])
+        #`(s-fun #,(loc stx) 'f-id params args return
+                 #,(parse-string #'s)
+                 (s-block #,(loc stx) (list stmt2 stmts ...))))]
+    [(_ "fun" (fun-header params fun-name args return) ":" body)
+     (with-syntax ([f-id (parse-id #'fun-name)])
+        #`(s-fun #,(loc stx) 'f-id params args return "" body))]))
 
 (define-syntax (lambda-expr stx)
   (syntax-case stx (lambda-args)
     [(_ "\\" (lambda-args arg ... lastarg) ":" "(" body ")")
-      #`(s-lam #,(loc stx) empty (list arg ... lastarg) (a-blank) body)]
+      #`(s-lam #,(loc stx) empty (list arg ... lastarg) (a-blank) "" body)]
     [(_ "\\" "(" body ")")
-     #`(s-lam #,(loc stx) empty empty (a-blank) body)]
+     #`(s-lam #,(loc stx) empty empty (a-blank) "" body)]
     [(_ "\\" (lambda-args arg ... lastarg) "->" ann ":" "(" body ")")
-     #`(s-lam #,(loc stx) empty (list arg ... lastarg) ann body)]
+     #`(s-lam #,(loc stx) empty (list arg ... lastarg) ann "" body)]
     [(_ "\\" "->" ann ":" "(" body ")")
-     #`(s-lam #,(loc stx) empty empty ann body)]))
+     #`(s-lam #,(loc stx) empty empty ann "" body)]))
 
 
 (define-syntax (arg-elt stx)

src/lang/pyret-lib/charter.arr

@@ -5,10 +5,10 @@
 import "file.arr" as file
 import "directory.arr" as directory
 
-#--| extract takes as input a path to a .arr file, and the path to an
-#    file where it will write the formatted documentation (just html
-#    for now)
 fun extract(input-path :: String, output-path :: String):
+  """extract takes as input a path to a .arr file, and
+     the path to an file where it will write the formatted
+     documentation (just html for now)"""
   def out: ""
 	def f: file.file(input-path)
   def reading-doc: false
@@ -28,7 +28,7 @@ fun extract(input-path :: String, output-path :: String):
 						reading-doc = false
           | true => false
         end
-        cond
+        cond:
           | reading-doc =>
             out.append(l.from(1))
 					  out.append("\n")

src/lang/runtime.rkt

@@ -20,6 +20,7 @@
               [mk-bool p:mk-bool]
               [mk-str p:mk-str]
               [mk-fun p:mk-fun]
+              [mk-fun-nodoc p:mk-fun-nodoc]
               [mk-method p:mk-method]
               [meta-null p:meta-null]
               [empty-dict p:empty-dict]
@@ -36,7 +37,8 @@
               [seal-pfun seal]
               [brander-pfun brander]
               [check-brand-pfun check-brand]
-	      [raise-pfun raise])
+              [keys-pfun keys]
+              [raise-pfun raise])
   Any?
   Number?
   String?
@@ -90,8 +92,12 @@
 (define: (mk-str (s : String)) : Value
   (p-str (none) meta-str (set) empty-dict s))
 
-(define: (mk-fun (f : Procedure)) : Value
-  (p-fun (none) meta-null (set) empty-dict
+(define: (mk-fun (f : Procedure) (s : String)) : Value
+  (p-fun (none) meta-null (set) (make-immutable-hash `(("doc" . ,(mk-str s))))
+	 (λ (_) f)))
+
+(define: (mk-fun-nodoc (f : Procedure)) : Value
+  (p-fun (none) meta-null (set) (make-immutable-hash `(("doc" . ,nothing)))
 	 (λ (_) f)))
 
 (define: (mk-opaque (v : Any)) : Value
@@ -118,23 +124,23 @@
 (define Racket (mk-object empty-dict))
 
 (define Any?
-  (mk-fun (lambda (o) (mk-bool #t))))
+  (mk-fun-nodoc (lambda (o) (mk-bool #t))))
 
 (define Number?
-  (mk-fun (lambda (n)
+  (mk-fun-nodoc (lambda (n)
 	    (mk-bool (p-num? n)))))
 
 (define String?
-  (mk-fun (lambda (n)
+  (mk-fun-nodoc (lambda (n)
 	    (mk-bool (p-str? n)))))
 
 (define Bool?
-  (mk-fun (lambda (n)
+  (mk-fun-nodoc (lambda (n)
 	    (mk-bool (p-bool? n)))))
 
 (define: (get-racket-fun (f : String)) : Value
   (define fun (dynamic-require 'racket (string->symbol f)))
-  (mk-fun (lambda: (args : Value *)
+  (mk-fun-nodoc (lambda: (args : Value *)
             (wrap (cast (apply fun (map unwrap args)) Any)))))
 
 (define: (get-raw-field (v : Value) (f : String)) : Value
@@ -149,7 +155,7 @@
       (get-racket-fun f)
       (match (get-raw-field v f)
         [(p-method _ _ _ _ f)
-               (mk-fun (lambda: (args : Value *)
+               (mk-fun-nodoc (lambda: (args : Value *)
                          ;; TODO(joe): Can this by typechecked?  I think maybe
                          (cast (apply f (cons v args)) Value )))]
         [non-method non-method])))
@@ -210,40 +216,51 @@
                                    (set-intersect fields-seal current-seal)))]
         (reseal object new-seal))))
 
-(define seal-pfun (mk-fun seal))
+(define seal-pfun (mk-fun-nodoc seal))
+
+
+(define: (get-visible-keys (m : Dict) (d : Dict) (s : Seal)) : (Setof String)
+  (define existing-keys
+    (set-union (list->set (hash-keys m))
+               (list->set (hash-keys d))))
+  (if (none? s)
+      existing-keys
+      (set-intersect existing-keys s)))
 
 (define: (flatten (base : Value)
                   (extension : Dict))
          : Value
   (define m (get-meta base))
   (define d (get-dict base))
   (define s (get-seal base))
-  (define existing-keys
-    (set-union (list->set (hash-keys m))
-               (list->set (hash-keys d))))
-  (define keys
-    (if (none? s)
-        existing-keys
-        (set-intersect existing-keys s)))
+  (define keys (get-visible-keys m d s))
   (define: (create-member (key : String)) : (Pairof String Value)
     (cons key (hash-ref d key (thunk (hash-ref m key)))))
   (define new-meta
     ((inst make-immutable-hash String Value)
      (set-map keys create-member)))
   (p-object (none) new-meta (set) extension))
 
+(define: (keys (obj : Value)) : Value
+  (define m (get-meta obj))
+  (define d (get-dict obj))
+  (define s (get-seal obj))
+  (mk-list (set-map (get-visible-keys m d s) mk-str)))
+
+(define keys-pfun (mk-fun-nodoc keys))
+
 (define: (brander) : Value
   (define: sym : Symbol (gensym))
   (mk-object 
    (make-immutable-hash 
     `(("brand" .
-       ,(mk-fun (lambda: ((v : Value))
+       ,(mk-fun-nodoc (lambda: ((v : Value))
                  (add-brand v sym))))
       ("check" .
-       ,(mk-fun (lambda: ((v : Value))
+       ,(mk-fun-nodoc (lambda: ((v : Value))
                  (mk-bool (has-brand? v sym)))))))))
 
-(define brander-pfun (mk-fun brander))
+(define brander-pfun (mk-fun-nodoc brander))
 (define (pyret-true? v)
   (match v
     [(p-bool _ _ _ _ #t) #t]
@@ -416,7 +433,7 @@
      (format "{ ~a }" (string-join (hash-map h field-to-string) ", "))]
     [v (format "~a" v)]))
 
-(define print-pfun (mk-fun (λ: ([o : Value]) (begin (printf "~a\n" (to-string o)) nothing))))
+(define print-pfun (mk-fun-nodoc (λ: ([o : Value]) (begin (printf "~a\n" (to-string o)) nothing))))
 
 
 (define check-brand

src/lang/typecheck.rkt

@@ -6,8 +6,8 @@
 (define (wrap-ann-check loc ann e)
   (s-app loc (ann-check loc ann) (list e)))
 
-(define (mk-lam loc args result body)
-  (s-lam loc empty args result (s-block loc (list body))))
+(define (mk-lam loc args result doc body)
+  (s-lam loc empty args result doc (s-block loc (list body))))
 
 (define (string-of-ann ann)
   (match ann
@@ -18,10 +18,13 @@
     [(a-app _ base args) (format "~a~a" base (map string-of-ann args))]))
 
 (define (ann-check loc ann)
+  (define (mk-contract-doc ann)
+    (format "internal contract for ~a" ann))
   (define ann-str (s-str loc (string-of-ann ann)))
   (define (mk-flat-checker checker)
     (define argname (gensym))
     (mk-lam loc (list (s-bind loc argname (a-blank))) ann
+            (mk-contract-doc ann)
             (s-app
              loc
              (s-id loc 'check-brand)
@@ -45,7 +48,9 @@
        (match bind
          [(s-bind s id ann) (wrap-ann-check s ann (s-id s id))]))
      (mk-lam s (list (s-bind s funname ann)) ann
+      (mk-contract-doc ann)
       (mk-lam s wrapargs result
+       (mk-contract-doc ann)
        (wrap-ann-check s result 
         (s-app s (s-id s funname) (map check-arg wrapargs)))))]
 
@@ -82,11 +87,11 @@
     [(s-def s bnd val)
      (s-def s bnd (wrap-ann-check s (s-bind-ann bnd) (cc val)))]
 
-    [(s-lam s typarams args ann body)
+    [(s-lam s typarams args ann doc body)
      (define body-env (foldr update env args))
      (wrap-ann-check s
                      (get-arrow s args ann)
-                     (s-lam s typarams args ann (cc-env body body-env)))]
+                     (s-lam s typarams args ann doc (cc-env body body-env)))]
 
     ;; TODO(joe): give methods an annotation position for result
     [(s-method s args body)