(module apf mzscheme (require (lib "etc.ss") (lib "list.ss") "list-util.scm" "apf-parse.scm") (provide traverse ;traverse-b ;traverse-bc ;traverse-ba ;traverse-bac parse parse-string concrete abstract def-list funcset id TP idA union-id union-TP union-idA union-TU build-TU union-func everywhere one-step make-bypass make-empty make-cons make-cons.first make-cons.rest any? delta subtype? PARSABLES) ;; Subtypes is (listof (list Symbol:sub Symbol:super)) (define SUBTYPES '((cons list) (empty list) (true boolean);ean) (false boolean);ean) (cons.first any-field) (cons.rest any-field))) (define (add-subtypes! types) (set! SUBTYPES (append types SUBTYPES))) ;; PARSABLES is a list of rules for the parsing grammar (define PARSABLES '()) (define (add-parsable! rule) (set! PARSABLES (cons rule PARSABLES))) ;; CONCRETES is a (listof (list Symbol (listof Symbol))) ;; It is a list of (DataType, FieldNames) pairs (define CONCRETES '((cons (first rest)))) (define (add-concrete! lst) (set! CONCRETES (cons lst CONCRETES))) ;; get-fields: Symbol -> (listof Symbol) ;; Get the list of field names for the given type (define (get-fields type) (letrec ((get* (lambda (lst) (cond [(null? lst) lst] [(symbol=? (caar lst) type) (cadar lst)] [else (get* (cdr lst))])))) (get* CONCRETES))) ;; parse: Symbol InputPort -> Any ;; Parse a data-structure given the start symbol from an input port (define (parse sym port) (gen-parse PARSABLES sym port)) ;; parse-string: Symbol String -> Any ;; Parse a data-structure given the start symbol from a String (define (parse-string sym str) (parse sym (open-input-string str))) ;; creator: Symbol -> Symbol ;; Returns the structure creator symbol for the given type/symbol (define (creator sym) (string->symbol (string-append "make-" (symbol->string sym)))) ;; type-pred: Symbol -> Symbol ;; Returns the predicate symbol for a given type/symbol (define (type-pred sym) (string->symbol (string-append (symbol->string sym) "?"))) ;; field-names: (listof [String | (list Symbol Symbol)] -> (lsitof Symbol) ;; Grab just the field name symbols from a list of syntax and field defs (define (field-names lst) (map car (filter (lambda (e) (not (string? e))) lst))) ;; parsables: (listof [String | (list Symbol Symbol)] -> (lsitof [String|Symbol]) ;; Grab just the field name symbols from a list of syntax and field defs (define (parsables lst) (map (lambda (e) (if (string? e) e (cadr e))) lst)) ;; concrete: Symbol (listof (list Symbol Symbol)) -> Unit ;; Defines a concrete Product Type (using a structure def) (define-syntax concrete (syntax-rules () ((concrete name lst) (define-prod 'name 'lst)))) ;; The real function... (define (define-prod name lst) (let ((fields (field-names lst))) ;;(display name)(newline) (eval `(define-struct ,name ,fields ,(make-inspector))) ;; When we define the Constructor, we could also check each ;; of the fields for "type" consistency... (eval `(define ,(cons name fields) ,(cons (creator name) fields))) (define-fields name fields) (add-parsable! (make-prod-rule name (parsables lst))) (add-keywords! (filter string? lst)) (add-concrete! (list name fields)))) ;; define-fields: Symbol (listof Symbol) -> Unit ;; Define types to encode each field during traversal for Augmentor functions (define (define-fields type fields) (add-subtypes! (create-sub-relate 'any-field (map (lambda (fn) (let ((ftn (field-type-name type fn))) (eval `(define-struct ,ftn () ,(make-inspector))) ftn)) fields)))) ;; field-type-name: Symbol Symbol -> Symbol ;; Computes the encoded name of the type that represents the field of ;; the given type... essentially just: "type.fieldname" (define (field-type-name type field) (string->symbol (string-append (symbol->string type) "." (symbol->string field)))) ;; create-pred: Symbol -> Function ;; Create a function which calles the given type's predicate, used ;; in the creation of a sum-type's predicate function (define (create-pred sym) (lambda (s) (list (type-pred s) sym))) ;; create-sub-relate: Symbol (listof Symbol) -> (listof (list Symbol Symbol)) ;; Creates a list of (subtype supertype) pairs for the non-reflexive, ;; anti-symetric 'subtype' relation (just 'lessthan') (define (create-sub-relate name subs) (if (null? subs) '() (cons (list (car subs) name) (create-sub-relate name (cdr subs))))) ;; abstract: Symbol (listof Symbol) -> Unit ;; Defines an abstract Sum Type (flat inheritence) (define-syntax abstract (syntax-rules () ((abstract name lst) (define-sum 'name 'lst)))) ;; The real function... (define (define-sum name lst) (eval `(define (,(type-pred name) t) ,(cons 'or (map (create-pred 't) lst)))) (add-subtypes! (create-sub-relate name lst)) (add-parsable! (make-sum-rule name lst))) ;; info: Struct-Instance -> (values Symbol Number (Struct Number -> Any)) ;; Grabs the relevant fields of the struct-type-info of the given structure, ;; which are: type-name, num-fields, and accessor-function (define (info str) (let*-values (((si d) (struct-info str)) ((name fields d1 acc d2 d3 d4 d5) (struct-type-info si))) (values name fields acc))) ;; type-symbol: Any -> Symbol (define (type-symbol f) (cond [(symbol? f) 'symbol] [(number? f) 'number] [(string? f) 'string] [(char? f) 'char] [(boolean? f) (if f 'true 'false)] [(empty? f) 'empty] [(cons? f) 'cons] [(struct? f) (let-values (((n f acc) (info f))) n)] [else 'any])) ;; type-symbols: (listof Any) -> (listof Symbol) ;; Reflect on the list and return the corresponding types (as symbols) (define (type-symbols fl) (map type-symbol fl)) ;; trav-fields: Struct (Stuct -> Any) Number Number -> (listof Any) ;; Traverse each of the fields using the accessor function, creating ;; a list of the return values (define (trav-fields tsym str flds acc i max B A C targ) ;(display (string-append " Traverse: " (symbol->string tsym) " # " (number->string i))) (if (= i max) (if (apf-none? targ) '() (list (apf-some-arg targ))) (cons (let ((fld (acc str i)) (uparg (update-arg (field-type-name tsym (car flds)) str targ A))) (if (C str i) (do-traverse fld B A C uparg) fld)) (trav-fields tsym str (cdr flds) acc (+ i 1) max B A C targ)))) (define (update-arg f-type str targ A) (if (apf-none? targ) targ (let* ((ft-inst (eval (list (creator f-type)))) (oarg (apf-some-arg targ)) (narg (delta A (list str ft-inst oarg) -1))) (make-apf-some narg)))) ;; Some/None for Optional Arguments (define-struct apf-none ()) (define-struct apf-some (arg)) ;; A ControlFunc is a function of the type: ;; Symbol Number -> Boolean ;; It returns whether the given field should be traversed ;; make-bypass: (listof (list Symbol Symbol)) -> ControlFunc (define-syntax make-bypass (syntax-rules () ((make-bypass edges ...) (make-bypass-f '(edges ...))))) ;; The real function... (define (make-bypass-f loedge) (let ((loenum (map find-field-num loedge))) (lambda (str num) (not (check-field-num loenum (type-symbol str) num))))) ;; find-field-num: (list Symbol Symbol) -> (list Symbol Number) ;; Replace the field name in the edge with its number in the structure (define (find-field-num edge) (let* ((par (first edge)) (name (second edge)) (entries (lookup CONCRETES (lambda (t) (symbol=? t par)) car cadr))) (if (empty? entries) (begin (error 'find-field-num "Type Not Found: ~s" par)) (let ((idx (index-of (lambda (s) (symbol=? s name)) (first entries)))) (if (< idx 0) (error 'find-field-num "Field Not Found: ~s" name) (list par idx)))))) ;; check-field-num: (listof (list Symbol Number)) Symbol Number -> Boolean ;; Find the Symbol/Number pair in the given List (define (check-field-num loedge sym num) (if (empty? loedge) false (or (and (symbol=? (caar loedge) sym) (= (cadar loedge) num)) (check-field-num (cdr loedge) sym num)))) ;; everywhere: Symbol Number -> Boolean ;; Sends the Traversal through every field (define (everywhere type fnum) true) ;; one-step: Symbol Number -> Boolean ;; Returns false, which sets up the "one-step" traversal (define (one-step type fnum) false) ;; traverse : Any (listof Function) ... -> Any ;; Main entry point for traversal. Chooses the most obvious traversal ;; function based on the number of arguments (see below for the cases) (define (traverse str B . others) (let ([len (length others)]) (cond [(= len 0) (traverse-b str B)] [(= len 1) (traverse-bc str B (car others))] [(= len 2) (traverse-ba str B (car others) (cadr others))] [(= len 3) (traverse-bac str B (car others) (cadr others) (caddr others))] [else (error 'traverse "Wrong Number of Arguments, must be 2,3,4, or 5")]))) ;; Traverse with just a Builder (define (traverse-b str B) (do-traverse str B idA everywhere (make-apf-none))) ;; Traverse with just a Builder and Argument modifier (define (traverse-ba str B A arg) (do-traverse str B A everywhere (make-apf-some arg))) ;; Traverse with just a Builder + Control (define (traverse-bc str B C) (do-traverse str B idA C (make-apf-none))) ;; Traverse with a Builder and Argument modifier + Control (define (traverse-bac str B A C arg) (do-traverse str B A C (make-apf-some arg))) ;; cons-accessor: Cons Number -> Any (define (cons-accessor c i) (cond [(= i 0) (first c)] [(= i 1) (rest c)] [else (error 'cons-accessor "Cons only has two Fields!!")])) (define-struct any-field ()) (define (make-cons x y) (cons x y)) (define-struct cons.first () (make-inspector)) (define-struct cons.rest () (make-inspector)) (define (make-empty) empty) (define (any? x) #t) ;; do-traverse: Any (listof Function) (listof Function) ControlFunc ;; (apf-none or apf-some) -> Any ;; ;; Run the APF Traversal on a Struct or Atomic data, applying the ;; Builder/Augmentos function sets during traversal with wrapped traversal argument (define (do-traverse str B A C targ) (let ((argl (if (apf-none? targ) '() (list (apf-some-arg targ))))) (if (or (struct? str) (cons? str) (null? str)) (let-values (((nm f acc) (cond [(struct? str) (info str)] [(cons? str) (values 'cons 2 cons-accessor)] [(null? str) (values 'empty 0 empty)]))) (let ((flds (trav-fields nm str (get-fields nm) acc 0 f B A C targ))) (delta B (cons str flds) -1))) (delta B (cons str argl) 0)))) ;; A Function is: (list (list Symbol) func/lambda) ;; func-arity: Function -> Number ;; Get the number of arguments this Function should take (define (func-arity f) (length (func-types f))) ;; func-func: Function -> (listof Symbol) ;; Get the types this Function accepts (define (func-types f) (car f)) ;; func-func: Function -> func/lambda ;; Get the scheme function corresponding to this Function (define (func-func f) (cadr f)) ;; delta: (listof Function) (listof Any) -> Any ;; Apply the 'best' Function to the arguments (define (delta lof lobj deflt) (let* ((types (type-symbols lobj)) (filt (func-filter lof types (length lobj)))) (if (null? filt) (if (< deflt 0) (begin (display "No Applicable FUNCTION Found for:")(newline) (display types)(newline)(newline) ;(map write lobj)(newline)(newline) (display "In funcset:")(newline) (map (lambda (f) (display " ")(display f)(newline)) lof) (newline) (error 'delta "BAD")) (list-ref lobj deflt)) (let ((sorted (func-sort filt))) (func-apply (car sorted) lobj))))) ;; func-apply: Function (listof Any) -> Any ;; Apply the given Function to a subsequence of the given argument list (define (func-apply func lobj) (apply (func-func func) (trim-list lobj (func-arity func)))) ;; func-filter: (listof Function) (listof Symbols) Number -> (listof Function) ;; Filter the Functions to only those that are applicable to the given ;; types (represented as Symbols) (define (func-filter lof lots len) (filter (lambda (fun) (and (<= (func-arity fun) len) (applicable? lots (func-types fun)))) lof)) ;; applicable: (lsitof Symbol) (listof Symbol) -> Boolean ;; Return whether the formal argument types are applicable to the ;; actual argument types (represented as Symbols) (define (applicable? aats fats) (or (null? fats) (let ((aa (car aats)) (fa (car fats))) (and (or (type=? aa fa) (subtype? aa fa)) (applicable? (cdr aats) (cdr fats)))))) ;; subtype?: Symbol Symbol -: Boolean ;; Is the first type (rep. by a Symbol) a subtype of the second (define (subtype? s1 s2) (and (not (type=? s1 s2)) (or (type=? s2 'any) (let ((supt (lookup SUBTYPES (lambda (s) (symbol=? s1 s)) car cadr))) (if (null? supt) #f (or (ormap (lambda (sym) (symbol=? sym s2)) supt) (ormap (lambda (sym) (subtype? sym s2)) supt))))))) ;; func-sort: (listof Function) -> (listof Function) ;; Sort a list of Functions by 'specificity' (define (func-sort lof) (sort lof func-less?)) ;; more-specific?: (listof Symbol) (listof Symbol) Number -> Boolean (define (more-specific? ft1 ft2 n1 n2) (cond [(and (= n1 0) (= n2 0)) false] [(= n2 0) true] [(= n1 0) false] [else (or (subtype? (car ft1) (car ft2)) (and (type=? (car ft1) (car ft2)) (more-specific? (cdr ft1) (cdr ft2) (- n1 1) (- n2 1))))])) ;; func-less?: Function Function -> Boolean ;; Is Function 1 (really, the types it accepts) more specific than Function 2 (define (func-less? f1 f2) (let ((n1 (func-arity f1)) (n2 (func-arity f2))) (more-specific? (func-types f1) (func-types f2) n1 n2))) ;; type=? : symbol symbol -> Boolean ;; Compare two type symbols for equality (define type=? symbol=?) ;; symbol-for: Symbol String -> Symbol ;; Create a symbol by appending a string to a given one... (define (symbol-for sym str) (string->symbol (string-append (symbol->string sym) str))) ;; def-list... Helper for annoying lists (define-syntax def-list (syntax-rules () ((def-list prefix type term) (define-list 'prefix 'type term)))) ;; The real function... (define (define-list prefix type term) (define-sum (symbol-for prefix "-list") (list (symbol-for prefix "-empty") (symbol-for prefix "-cons"))) (define-prod (symbol-for prefix "-empty") (list term)) (define-prod (symbol-for prefix "-cons") `((first ,type) (rest ,(symbol-for prefix "-list"))))) ;; Syntax for function set definitions... ;; (funcset ((type-1 type-2 ...) (formal-1 formal-2 ...) Expression) ;; ( ... another ... ) ...) (define-syntax funcset (syntax-rules () ((funcset) '()) ((funcset ((types ...) (ids ...) expr) rest ...) (if (not (= (length '(types ...)) (length '(ids ...)))) (error "The number of types and arguments don't match") (cons `((types ...) ,(lambda (ids ...) expr)) (funcset rest ...)))) ((funcset (() () expr) rest ...) (cons `(() ,(lambda () expr)) (funcset rest ...))) ;((funcset ((types ...) (ids ...) expr)) ; (list `((types ...) ,(lambda (ids ...) expr)))) ;((funcset (() () expr)) ; (list `(() ,(lambda () expr)))) )) ;; idA implementation (define idA (funcset ((any any-field any) (o f a) a))) (define-syntax union-idA (syntax-rules () ((union-idA funcs ...) (union-func (funcset funcs ...) idA)))) ;; id implementation (define id (funcset ((symbol) (o) o) ((number) (o) o) ((string) (o) o) ((char) (o) o) ((boolean) (o) o))) (define-syntax union-id (syntax-rules () ((union-idA funcs ...) (union-func (funcset funcs ...) id)))) ;; Default Constructor... calls the constructor for the first argument ;; on the other arguments (as many as are needed) (define (construct . lst) (let ((p (car lst))) (if (or (struct? p) (cons? p) (null? p)) (let-values (((n f a) (cond [(struct? p) (info p)] [(cons? p) (values 'cons 2 0)] [(null? p) (values 'empty 0 0)]))) (let* ((args (trim-list (cdr lst) f)) (wrap (map (lambda (s) (if (symbol? s) '(quote s) s)) args))) (apply (eval (creator n)) args))) ;; Else p))) ;; Generate one "function" with 'i' arguments (define (func-Bc type i) (list (repeat-list type i) construct)) ;; Create a fold function using the given functions... (define (make-fold f d) (lambda (old . lst) (if (null? lst) d (let ((r (reverse lst))) (foldr f (car r) (cdr r)))))) ;; Generate one TU "function" with 'i' arguments (define (func-TU type fun def i) (list (cons 'any (repeat-list type i)) (make-fold fun def))) ;; Make TU functions for the given type, using the function ;; to fold two results, and 'def' as the default value for ;; invocations that are not matched. (define (build-a-TU type fun def) (letrec ((build (lambda (i) (if (> i 10) '() (cons (func-TU type fun def i) (build (+ i 1))))))) (build 0))) (define-syntax build-TU (syntax-rules () ((union-TU type fun def) (build-a-TU 'type fun def)))) (define-syntax union-TU (syntax-rules () ((union-TU type fun def funcs ...) (union-func (funcset funcs ...) (build-a-TU 'type fun def))))) ;; Extends the second function 'object' with the first (define (union-func F1 F2) (append F1 F2)) ;; Default Builder... reconstructs the structure(s) (define TP (letrec ((build-Bc (lambda (type i max) (if (> i max) '() (cons (func-Bc type i) (build-Bc type (+ i 1) max)))))) (union-func (build-Bc 'any 1 10) id))) (define-syntax union-TP (syntax-rules () ((union-TP funcs ...) (union-func (funcset funcs ...) TP)))) ;; **** End of Module... )