Serialize scheme object to string - debugging

When doing (display obj), a nice representation is shown to the output. But is it possible to capture this representation to a string?
I could use this to better handle debug information.
The closest I could get is to display the object to a .txt, and then read it back as a string:
(define (to-string obj)
(call-with-output-file "to-string.txt"
(lambda (output-port)
(display obj output-port)))
(call-with-input-file "to-string.txt"
(lambda (input-port)
(define str "")
(let loop ((x (read-char input-port)))
(if (not (eof-object? x))
(begin
(set! str (string-append str (string x)))
(loop (read-char input-port))))
str)))
)
(define obj (cons "test" (make-vector 3)))
(define str (to-string obj))
; str will contain "{test . #(0 0 0)}"


Found the answer thanks to #soegaard!
(define (to-string obj)
(define q (open-output-string))
(write obj q)
(get-output-string q)
)
(define obj (cons "test" (make-vector 3)))
(define str (to-string obj))
; str will contain ("test" . #(0 0 0))

Related

Why do I get "application: not a procedure" with this for loop in Racket?

The following code reads a csv file and based on its content generates a Prolog program:
#!/usr/bin/env racket
#lang racket/base
(define (overwrite-s-to-f fname s); Will create fname and write overwriting the previous content.
(with-output-to-file #:exists 'truncate fname (lambda () (displayln s))))
(define (c-o-a-line-to-f fname s); Will append a string to fname or create it if does not exist. Appends a new line.
(with-output-to-file #:exists 'append fname (lambda () (displayln s))));
(define fname "women.csv")
(define pl-fname "females-by-Racket.pl")
(require racket/file)
(define content (file->lines fname))
(define disc-line (string-append ":-discontiguous(" (string-replace (car content) "Name," "") ").\n"))
(overwrite-s-to-f pl-fname disc-line)
(define list-of-verbs (string-split (string-replace (car content) "Name," "") ","))
(require racket/string racket/system)
(for ((row content));content is a list of strings
(let ((list-of-cs (string-split row ",")))
(when (equal? (car (cdr list-of-cs)) "+")
(displayln row)(let ((cmd (string-append "awesome("(car list-of-cs)").")))(c-o-a-line-to-f pl-fname cmd)(displayln cmd)))
(when (equal? (car (cdr (cdr list-of-cs))) "+")(displayln row)(let ((cmd (string-append "and_intelligent("(car list-of-cs)").")))
(c-o-a-line-to-f pl-fname cmd)(displayln cmd))))); TODO: when for each columns 2-last of women.csv
The content of women.csv:
Name,awesome,and_intelligent,performed_once,extreme1,extreme2,extreme3,extreme4,donkey_thing,dark_eyes,pigmented_face,pigmented_genitals,bleached,had_no_surgeries,has_augmented_breasts
adriana_chechik,+,,,+,?,+,+,,-,,,,,
alysa_gap,+,,,,?,+,+,,-,,,,,
anna_de_ville,+,,,,,+,+,,+,-,+,-,-,
aurora_jolie,+,+,,,,,,,+,+,+,,+,
autumn_falls,,,,,,,,,+,+,-,+,+,
casey_calvert,+,,,,,,,,+,+,+,,,
dahlia_sky,+,,,,,,+,,,,,,,
dominica_lito,+,,,,,,+,,,,,,,
ella_knox,,,,,,,,,+,+,+,,+,
isabella_clark,+,,,,,,+,,,,,,,
jade_kush,,,,,,,,,+,+,,,+,
juelz_ventura,+,,,,,+,,,-,-,,,-,+
kapri_styles,,,,,,,,,+,,+,,,
kristina_milan,,,,,,,,,+,+,,,+,
kylie_sinner,+,+,,,,,,,+,,,,-,
leigh_raven,+,,,,,+,,,+,+,,,,
maserati,,,,,,,,,+,+,,,+,
miosotis,,,,,,,,,+,+,,,+,
scarlett_bloom,,,,,,,,,+,+,+,,-,
sheena_shaw,,,,,,,,,-,,+,,-,
sofia_rose,,,,,,,,,+,,,,+,
teanna_trump,+,,,,,,,,+,,+,,,
veronica_avluv,+,,,,,,+,,,,,,,
yudi_pineda,+,,,,,,,,+,+,,,,
females-by-Racket.pl is to look like so:
:-discontiguous(awesome,and_intelligent,performed_once,extreme1,extreme2,extreme3,extreme4,donkey_thing,dark_eyes,pigmented_face,pigmented_genitals,bleached,had_no_surgeries,has_augmented_breasts).
awesome(adriana_chechik).
awesome(alysa_gap).
awesome(anna_de_ville).
awesome(aurora_jolie).
and_intelligent(aurora_jolie).
awesome(casey_calvert).
awesome(dahlia_sky).
awesome(dominica_lito).
awesome(isabella_clark).
awesome(juelz_ventura).
awesome(kylie_sinner).
and_intelligent(kylie_sinner).
awesome(leigh_raven).
awesome(teanna_trump).
awesome(veronica_avluv).
awesome(yudi_pineda).
but with more predicates (up to n-1 for each woman where n is the number of columns in women.csv)
The names of the columns or the numbers thereof in women.csv are likely to be frequently changed.
That is partly why I wish to avoid manually coding for every when. The other concerns are the sheer amount of the lines to code (15 whens for each column) and the risk of error/typo.
Is it doable to loop through every cell in list-of-cs in such way that it is taken from list-of-verbs?
I've tried this but to no avail (the comment show the error message that I got):
(for ((row content))
(let ((list-of-cs (cdr (string-split row ","))))
(for ((cell list-of-cs))
; application: not a procedure; expected a procedure
; that can be applied to arguments
(set! list-of-verbs (cdr (list-of-verbs)))
(let ((verb (car list-of-verbs)))
(when (equal? cell "+")
(displayln row)
(let ((cmd (string-append verb "(" (car row) ").")))
(c-o-a-line-to-f pl-fname cmd)))
))))

named let is a useful form to be familiar with:
#lang scheme
(define (csv->attributes rows) ;; ListOfString -> ListOfString
;; produce "column-header(row-name)" for "+" entries in csv (see example)
(let ([fields (string-split (car rows) ",")])
(let next-row ([rows (cdr rows)] [result (list)])
(cond
[(null? rows) (reverse result) ]
[else
(let* ([cells (string-split (car rows) ",")]
[name (car cells)])
(let next-cell ([cells (cdr cells)] [fields (cdr fields)] [result result])
(cond
[(null? cells) (next-row (cdr rows) result) ]
[else (next-cell
(cdr cells) (cdr fields)
(if (string=? (car cells) "+")
(cons (string-append (car fields) "(" name ")") result)
result)) ]))) ]))))
(define trio '("Name,fast,slow,sidles"
"Achilles,+,,"
"Tortoise,,+,"
"Crab,,+,+"))
Welcome to DrRacket, version 8.5 [cs].
Language: scheme, with debugging.
> (csv->attributes trio)
("fast(Achilles)" "slow(Tortoise)" "slow(Crab)" "sidles(Crab)")
>

Call of non procedure <#unspecific>

I'm trying to convert sexps to xml, I have a recursive function that goes through a list representing an xml tag and its child tags, and then prints them to the standard output with correct indentation.
I'm using the chicken scheme compiler.
source:
(use srfi-13)
(use extras)
;Returns the length of a list
(define (len lst)
(define (len-help lst count)
(cond ((not (eq? lst '())) (len-help (cdr lst) (+ count 1)))
(else count)))
(len-help lst 0))
(define (const-l fil len)
;makes a constant list of symbol fil len times
(cond ((> len 0) (cons fil (const-l fil (- len 1))))
(else '())))
;makes a string out of a list of tag attribute strings
(define (make-attribute-string tag-atribs)
(cond ((eq? tag-atribs '()) "")
(else (string-join tag-atribs " "))))
(define (indent num)
(string-join (const-l " " num) ""))
;makes a tag structure from args
;tag-name is a symbol
;tag-attribs is a lis of tag attribute strings
;i.e.: '("att1='val1'" "att2='val2'")
(define (make-tag tag-label tag-atribs tag-elements)
`(,tag-label ,(make-attribute-string tag-atribs) ,tag-elements))
(define (tag-name tag)
(car tag))
(define (tag-atribs tag)
(cadr tag))
(define (tag-elems tag)
(caddr tag))
(define (print-tag tag close ind)
(cond ((eq? close #f) (printf "~A<~A ~A>" (indent ind) (tag-name tag) (tag-atribs tag)))
((eq? close #t) (printf "~A<~A/>" (indent ind)(tag-name tag)))))
(define (display-heir tag)
(define (recursive-display tag indent)
(print-tag tag #f indent)
(newline)
(cond ((not (eq? (tag-elems tag) '()))
(map (lambda (tg) (
(recursive-display tg (+ indent 1))))
(tag-elems tag))))
(print-tag tag #t indent)
(newline))
(recursive-display tag 0))
(define tg3 (make-tag 'Person '("name='Joe'" "age='5'" "sex='Male'") '()))
(define tg4 (make-tag 'Person '("name='Sally'" "age='1'" "sex='Female'") '()))
(define tg2 (make-tag 'children '() (list tg3 tg4)))
(define tg1 (make-tag 'Person '("name='Bob'" "age='21'" "sex='Male'") (list tg2)))
;this doesnt work, stops working after printing first element in innermost
;level of the heirarchy, should work like the next block with some additional
;newlines
(display-heir tg1)
;this displays the tags correctly
(print-tag tg1 #f 0)
(newline)
(print-tag tg2 #f 1)
(newline)
(print-tag tg3 #f 2)(print-tag tg3 #t 0)
(newline)
(print-tag tg4 #f 2)(print-tag tg4 #t 0)
(newline)
(print-tag tg2 #t 1)
(newline)
(print-tag tg1 #t 0)
I compiled it with normal settings csc xml.scm -o xml.exe
I get the following
C:\Users\jorda\Documents\iupprac\more>csc xml.scm
C:\Users\jorda\Documents\iupprac\more>xml
<Person name='Bob' age='21' sex='Male'>
<children >
<Person name='Joe' age='5' sex='Male'>
<Person/>
Error: call of non-procedure: #<unspecified>
Call history:
xml.scm:45: newline
xml.scm:46: tag-elems
xml.scm:50: print-tag
xml.scm:40: ##sys#check-output-port
xml.scm:40: indent
xml.scm:21: const-l
xml.scm:12: const-l
xml.scm:12: const-l
xml.scm:21: string-join
xml.scm:40: ##sys#print
xml.scm:40: ##sys#write-char-0
xml.scm:40: tag-name
xml.scm:40: ##sys#print
xml.scm:40: ##sys#print
xml.scm:51: newline
xml.scm:47: g105 <--
If you remove the (display-heir tg1) it gives the correct output with the code that follows after that line:
<Person name='Bob' age='21' sex='Male'>
<children >
<Person name='Joe' age='5' sex='Male'><Person/>
<Person name='Sally' age='1' sex='Female'><Person/>
<children/>
<Person/>

The problem here is the procedure that you pass to map:
(define (display-heir tag)
(define (recursive-display tag indent)
(print-tag tag #f indent)
(newline)
(cond ((not (eq? (tag-elems tag) '()))
(map (lambda (tg) (
(recursive-display tg (+ indent 1))))
(tag-elems tag))))
(print-tag tag #t indent)
(newline))
If you indent this correctly, you may spot the problem more easily:
(define (display-heir tag)
(define (recursive-display tag indent)
(print-tag tag #f indent)
(newline)
(cond ((not (eq? (tag-elems tag) '()))
(map (lambda (tg) (
(recursive-display tg (+ indent 1))))
(tag-elems tag))))
(print-tag tag #t indent)
(newline))
(recursive-display tag 0))
As you can (hopefully) see, the call to recursive-display is wrapped in an extra set of parentheses. This means it will try to call the result of recursive-display as a procedure (which it isn't, it's void or #<unspecified>)

How to print user-defined environment in scheme?

In general I want write code in REPL and sometimes save all defined by myself symbols to file.
For example - after typing in REPL:
]=> (define (square x) (* x x))
]=> (define sizes '(5 10 15))
I need to call something to receive a list of previously defined objects.
In this case it can be represented in this way:
]=> (define get-user-defined-environment
(list (list 'sizes sizes) (list 'square square)))
To be able then call something like this:
]=> (map
(lambda (lst) (begin
(display "(define ")
(pp (first lst))
(pp (second lst))
(display ")\n\n")))
get-user-defined-environment)
(define sizes
(5 10 15)
)
(define square
(named-lambda (square x)
(* x x))
)
And, maybe, save output to file somehow.
So, what could be this get-user-defined-environment ?

There isn't something in standard Scheme that lets you record the environment. You can however define your own define-like syntax that does it for you.
> (define *env* '())
> (define-syntax def&rec
(syntax-rules ()
((_ name init)
(define name
(let ((value init))
(set! *env* (cons (cons 'name value) *env*))
value)))))
> (def&rec foo 1)
> (def&rec bar (lambda (x) x))
> *env*
((bar . #<procedure value>) (foo . 1))
If you intend to write this to a file, like with the expectation of reading it back in, you will want to record the init form, not value in the syntax above. Here is another syntactic form to record the init:
> (define-syntax def&rec2
(syntax-rules ()
((_ name init)
(define name
(let ((value init))
(set! *env* (cons (list 'name value 'init) *env*))
value)))))
> (def&rec2 equal-to (lambda (x) (lambda (y) (equal? x y))))
> *env*
((equal-to #<procedure value>
(lambda (x) (lambda (y) (equal? x y))))
(bar . #<procedure value>) (foo . 1))

Thanks to uselpa pointed to How can find all functions and bounded symbols in an "environment"
(environment-bound-names (the-environment)) - returns a list of user-defined names.
Then (environment-lookup (the-environment) name) - returns value of a name in current environment.
Here is the way:
]=> (define (p1 name env) (begin (display "(define ") (pp name) (pp (environment-lookup env name)) (display ")\n\n")))
]=> (define (p2 lst env) (for-each (lambda (name) (p1 name env)) lst))
]=> (p2 (reverse (environment-bound-names (the-environment))) (the-environment))
(define p1
(named-lambda (p1 name env)
(display "(define ")
(pp name)
(pp (environment-lookup env name))
(display ")\n\n"))
)
(define p2
(named-lambda (p2 lst env)
(for-each (lambda (name) (p1 name env)) lst))
)

Turning a list of list to list of string using syntax->string

Basically, I want '( (whatever1) (whatever2) (whatever3) ... ) ===> ( "(whatever1)" "(whatever2)" "(whatever3)" ), which is just add quotes outside of the list, and keep the contents in the list unchanged. e.g.
'((define X ::int)
(define b0 :: bool (=> T (and (= X X) (= 0 0)))))
will be turned into:
'("(define X ::int)"
"(define b0 :: bool (=> T (and (= X X) (= 0 0))))")
However, the following code I am using eliminate all spaces!
#lang racket
(require syntax/to-string)
(define lst-sub '((define x :: int) (=> T (and (= X X) (= 0 0)))))
(pretty-write (map (λ (x) (string-append "(" (syntax->string (datum->syntax #f x)) ")")) lst-sub))
which returns
("(definex::int)" "(=>T(and(=XX)(=00)))")
So the question is: there is no spaces anymore!
How can I get around this??

#lang racket
(define lst-sub '((define x :: int) (=> T (and (= X X) (= 0 0)))))
(pretty-write (map (λ (x) (format "~s" x)) lst-sub))

Alright. I don't take the "easy" route I thought. and worked out as follows, which ends up with more lines of code :(
(define (toString-with-space data)
(match data
[(? symbol?) (string-append (symbol->string data) " ")]
[(? number?) (string-append (number->string data) " ")]))
(define (flat-def def-lst)
(if (empty? def-lst)
(list)
(begin
(let ([f (car def-lst)])
(if (not (list? f))
(cons (toString-with-space f) (flat-def (drop def-lst 1)))
(append (list "(") (flat-def f) (flat-def (drop def-lst 1)) (list ")")))))))
(define (lstStr->lstChars lst-str)
(for/fold ([l empty])
([el (in-list lst-str)])
(append l (string->list el))))
(define flat (flat-def ' (define b1 :: bool (=> (and (= X x) (= Y y)) (and (= Y y) (= X x))))))
(set! flat (append (list "\"" "(") flat (list ")" "\"")))
(set! flat (lstStr->lstChars flat))
(set! flat (list->string flat))
(display flat)

Scheme Formatting Help

I've been working on a project for school that takes functions from a class file and turns them into object/classes. The assignment is all about object oriented programming in scheme.
My problem however is that my code doesn't format right.
The output it gives me whenever I give it a file to pass in wraps the methods of the class in a list, making it so that the class never really gets declared. I can't for the life of me figure out how to get the parenthesis wrapping the method list to remove.
I would really appreciate any help.
Below is the output, the class file and the code,.
(define pointInstance
(let ((myx 1) (myy 2))
(lambda msg
(cond
(((eq? (car msg) getx) myx)
((eq? (car msg) gety) myy)
((eq? (car msg) setx) (set! myx x))
((eq? (car msg) show) (begin (display "[") (display myx) (display ",") (display myy) (display "]"))))))))
If you look at just after the cond you'll see how all those eq statements are contained in a list. I can't get this to work right unless they're not wrapped by that top level list.
;;;; PART1 --- A super-easy set of classes. Just models points and lines. Tests all of >the
;; basics of class behavior without touching on anything particularly complex.
(class pointInstance (parent:) (constructor_args:)
(ivars: (myx 1) (myy 2))
(methods:
(getx () myx)
(gety () myy)
(setx (x) (set! myx x))
(show () (begin (display "[") (display myx) (display ",") (display myy) (display "]")))
))
(require (lib "trace.ss"))
;; Continue reading until you hit the end of the file, all the while
;; building a list with the contents
(define load-file
(lambda (port)
(let ((rec (read port)))
(if (eof-object? rec)
'()
(cons rec (load-file port))))))
;; Open a port based on a file name using open-input-file
(define (load fname)
(let ((fport (open-input-file fname)))
(load-file fport)))
;(define lis (load "C:\\Users\\Logan\\Desktop\\simpletest.txt"))
;(define lis (load "C:\\Users\\Logan\\Desktop\\complextest.txt"))
(define lis (load "C:\\Users\\Logan\\Desktop\\pointinstance.txt"))
;(display (cdaddr (cdddar lis)))
(define makeMethodList
(lambda (listToMake retList)
;(display listToMake)
(cond
[(null? listToMake)
retList
;(display "The list passed in to parse was null")
]
[else
(makeMethodList (cdr listToMake) (append retList (list (getMethodLine listToMake))))
]
)
))
;(trace makeMethodList)
;this works provided you just pass in the function line
(define getMethodLine
(lambda (functionList)
`((eq? (car msg) ,(caar functionList)) ,(caddar functionList))))
(define load-classes
(lambda paramList
(cond
[(null? paramList) (display "Your parameters are null, man.")]
[(null? (car paramList))(display "Done creating class definitions.")]
[(not (null? (car paramList)))
(begin
(let* ((className (cadaar paramList))
(classInstanceVars (cdaddr (cddaar paramList)))
(classMethodList (cdr (cadddr (cddaar paramList))))
(desiredMethodList (makeMethodList classMethodList '()))
)
;(display "Classname: ")
;(display className)
;(newline)(newline)
;(display "Class Instance Vars: ")
;(display classInstanceVars)
;(newline)(newline)
;(display "Class Method List: ")
;(display classMethodList)
;(newline)
;(display "Desired Method List: ")
;(display desiredMethodList))
;(newline)(newline)
;----------------------------------------------------
;do not delete the below code!`
`(define ,className
(let ,classInstanceVars
(lambda msg
;return the function list here
(cond ,(makeMethodList classMethodList '())))
))
;---------------------------------------------------
))]
)
))
(load-classes lis)
;(load-classes lis)
;(load-classes-helper lis)
;(load-classes "simpletest.txt")
;(load-classes "complextest.txt")
;method list
;(display (cdr (cadddr (cddaar <class>))))

You have too many opening parenthesis in the 1st clause of the cond.
IE:
(((eq? (car msg) getx) myx)
^
Updated:
Are you looking for this?
(cond ,#(makeMethodList classMethodList '())
^^
Or you can do:
(cond . ,(makeMethodList classMethodList '())

Resources