提交: 26c0818884890fc485063d31725e96f4812642f8 - cammy (git)

A categorical programming language

Commit MetaInfo

• 修订版: 26c0818884890fc485063d31725e96f4812642f8 (tree)
• 时间: 2021-09-17 06:04:30
• 作者: Corbin <cds@corb...>
• Commiter: Corbin

Log Message

frame: Allow user-defined functors with parameters.

I waffled over this for a while, but ultimately it's going to be
necessary for expressivity.

更改概述

• modified: frame/frame.ml
• modified: stub.scm

差异

--- a/frame/frame.ml
+++ b/frame/frame.ml
@@ -13,24 +13,59 @@ let filter =
     PrimitiveFilter.empty
     (String.split_on_char ' ' primitives)
 
+let which_arg s =
+  let len = String.length s in
+  if len == 0 || s.[0] != '@' then None
+  else int_of_string_opt (String.sub s 1 (len - 1))
+
+let rec arity_of expr =
+  match expr with
+  | Atom a -> Option.fold ~none:0 ~some:(fun x -> x + 1) (which_arg a)
+  | List l -> List.fold_left max 0 (List.rev_map arity_of l)
+
+let is_primitive s =
+  Option.is_some (which_arg s) || PrimitiveFilter.mem s filter
+
 let cache = ref CodeCache.empty
 let basepath = Sys.argv.(1)
 
+let rec apply_functor args expr =
+  match expr with
+  | Atom a -> Option.fold ~none:expr ~some:(List.nth args) (which_arg a)
+  | List l -> List (List.hd l :: List.map (apply_functor args) (List.tl l))
+
 let rec replace_code node =
-  match node with
-  | Atom a -> do_atom a
-  | List l -> List (List.hd l :: List.map replace_code (List.tl l))
+  match node with Atom a -> do_atom a | List l -> do_list l
+
+and lookup s =
+  match CodeCache.find_opt s !cache with
+  | Some pair -> pair
+  | None ->
+      let fullpath = Filename.concat basepath s ^ ".cammy" in
+      let expr = replace_code (load_sexp fullpath) in
+      let arity = arity_of expr in
+      cache := CodeCache.add s (expr, arity) !cache ;
+      Printf.eprintf "Loaded %s, arity %d\n" s arity ;
+      (expr, arity)
 
 and do_atom s =
-  if PrimitiveFilter.mem s filter then Atom s
+  if is_primitive s then Atom s
   else
-    match CodeCache.find_opt s !cache with
-    | Some expr -> expr
-    | None ->
-        let fullpath = Filename.concat basepath s ^ ".cammy" in
-        let expr = replace_code (load_sexp fullpath) in
-        cache := CodeCache.add s expr !cache ;
-        expr
+    let expr, arity = lookup s in
+    if arity != 0 then failwith ("Functor " ^ s ^ " is not nullary") else expr
+
+and do_list l =
+  let tail = List.map replace_code (List.tl l) in
+  let head = List.hd l in
+  match head with
+  | Atom a ->
+      if is_primitive a then List (head :: tail)
+      else
+        let expr, arity = lookup a in
+        if arity != List.length tail then
+          failwith ("Functor " ^ a ^ " misapplied")
+        else apply_functor tail expr
+  | List l -> failwith "Functor heads cannot be lists!"
 
 let tree = input_sexp stdin
 

--- a/stub.scm
+++ b/stub.scm
@@ -61,6 +61,10 @@
   (let ((x (car args)))
     (if (flonum? x) (cons x (cdr args))
       (arg-error x "not a floating-point number"))))
+(define (arg-list p)
+  (lambda (args)
+    (let ((x (car args)))
+      (cons x (cdr args)))))
 (define (arg-pair p1 p2)
   (lambda (args1)
     (let* ((pair1 (p1 args1)) (x (car pair1)) (args2 (cdr pair1))
@@ -73,6 +77,7 @@
 (define ty-parse (match-lambda
                    ['N arg-nat]
                    ['F arg-fp]
+                   [('list x) (arg-list (ty-parse x))]
                    [('pair x y) (arg-pair (ty-parse x) (ty-parse y))]))
 
 (define (cammy-run program ty)