namespace unification starts working reasonable, buggs remain
[gule-log:guile-log.git] / logic / guile-log / prolog / namespace.scm
1 (define-module (logic guile-log prolog namespace)
2   #:use-module (logic guile-log code-load)
3   #:use-module ((logic guile-log)
4                 #:select (<define> <lookup> <=>))
5   #:use-module (logic guile-log umatch)
6   #:use-module (logic guile-log prolog closed)
7   #:use-module (logic guile-log prolog names)
8   #:use-module (ice-9 match)
9   #:use-module (ice-9 pretty-print)
10   #:re-export (    make-namespace
11                    namespace?
12                    namespace-val
13                    namespace-ns                     
14                    namespace-local?
15                    namespace-lexical?
16                    setup-namespace)
17
18   #:export (namespace_p
19             namespace_val
20             namespace_ns
21             namespace_local_p
22             namespace_lexical_p))
23
24 (<define> (namespace_p        
25            x)   (when (namespace?         (<lookup> x))))
26 (<define> (namespace_val      
27            x v) (<=> v ,(namespace-val    (<lookup> x))))
28 (<define> (namespace_ns       
29            x v) (<=> v ,(namespace-ns     (<lookup> x))))
30 (<define> (namespace_local_p  
31            x v) (when (namespace-local?   (<lookup> x))))
32 (<define> (namespace_lexical_p  
33            x v) (when (namespace-lexical? (<lookup> x))))
34
35 (define do-print #f)
36 (define pp
37   (case-lambda
38    ((s . x)
39     (when do-print
40       (pretty-print `(,s ,(syntax->datum x))))
41     x)
42    ((x)
43     (when do-print
44       (pretty-print (syntax->datum x)))
45     x)))
46
47 (define ppp
48   (case-lambda
49    ((s x)
50     (when #t
51       (pretty-print `(,s ,(syntax->datum x))))
52     x)
53    ((x)
54     (when #t
55       (pretty-print (syntax->datum x)))
56     x)))
57
58 #|
59 Unification that varifies namespaces in a unification e.g. we can do
60
61 X@@a = Y
62 X@   = current open module
63
64 Two things will happen
65 1) Var = string, will be translated to an actual function in a lookup 
66                  for the namespace
67 2) Var = atom,  atom have to be in the namespaced module.
68 3) new namespaces found changes the restricted namespace
69 |#
70
71 (define fail-when-new-namespace? (make-fluid #f))
72 (define (comp-fail? ns1 local1? ns2 local2? binary?)
73   (let ((fail (fluid-ref fail-when-new-namespace?)))
74     (if (and (equal? ns1 ns2) (or local1? (not local2?)))
75         #f
76         (if binary?
77             #t
78             (if fail
79                 (if (eq? fail #t)
80                     #t
81                     (let lp-wl ((l fail))
82                       (match l
83                         (((local? . dir) . l)
84                          (if (or local? (not local2?))
85                              (let lp ((dir dir) (ns ns2))
86                                (match dir
87                                  ((*) #f)
88                                  (()  (if (null? ns)
89                                           #f
90                                           (lp-wl l)))
91                                  ((x . dir)
92                                   (match ns
93                                     ((y . ns)
94                                      (if (equal? x y)
95                                          (lp dir ns)
96                                          (lp-wl l)))
97                                     (_ (lp-wl l))))))
98                              (lp-wl l)))
99                         (() #t))))
100                 #f)))))
101                           
102
103 (define (translate x ns l?)
104   (let ((sym (string->symbol x))
105         (mod (resolve-module ns)))
106     (if l?
107         (if (module-defined? mod sym)
108             (module-ref mod sym)
109             (let ((f (make-sym mod sym)))
110               (module-define! mod sym f)
111               f))
112         (let ((pub (module-public-interface mod)))
113           (if pub
114               (if (module-defined? pub sym)
115                   (module-ref pub sym)
116                   (let ((f (make-sym mod sym)))
117                     (module-define! mod sym f)
118                     (module-set! pub sym (module-ref mod sym))
119                     f))
120               #f)))))
121
122
123 (define (validate x ns local? s)
124   (define (f x s cont)
125     (cond
126      ((prolog-closure? x)
127       (if (validate (prolog-closure-parent x) ns local? s)
128           (validate (prolog-closure-state  x) ns local? s)
129           #f))
130     
131      ((namespace? x)
132       (if (comp-fail? ns local? (namespace-ns x) (namespace-local? x) #f)
133           #f
134           (if (namespace-lexical? x)
135               (error "lexical in validate is a bug!")
136               (validate (namespace-val    x) (namespace-ns x) 
137                         (namespace-local? x) s))))
138      
139      ((vector? x)
140       (validate (vector->list x) ns local? s))
141      
142      ((gp-var? x s)
143       s)
144
145      ((procedure? x)
146       (let ((mod (procedure-property x 'module)))
147         (if mod
148             (if (equal? mod ns)
149                 (if (not local?)
150                     (if (module-defined?
151                          (module-public-interface (resolve-module mod))
152                          (procedure-name x))
153                         s
154                         #f)
155                     s)
156                 #f)
157             #f)))
158      
159      (else
160       (cont x s))))
161
162   (pp 'validate x ns  local?)
163
164   (f x s
165    (lambda (x s)
166      (let lp ((s s) (x x))
167        (umatch (#:mode - #:status s #:name 'validate) (x)
168          ((x . l)
169           (let ((s (validate (gp-lookup x s) ns local? s)))
170             (if s
171                 (lp s (gp-lookup l s))
172                 s)))
173          (x (f x s (lambda (x s) s))))))))
174
175 (define (ns-unify  s ns y bang?) 
176   (pp 'ns-unify s ns y bang?)
177   (ns-unify* s ns y bang?))
178 (define (ns-unify* s xin y bang?)
179   (define (unify x y s)
180     (if bang?
181         (gp-unify! x y s)
182         (gp-m-unify! x y s)))
183
184   (let ((x    (gp-lookup (namespace-val xin) s))
185         (ns   (namespace-ns       xin))
186         (lx?  (namespace-local?   xin))
187         (lex? (namespace-lexical? xin)))
188     
189     (let lp ((x      (gp-lookup x s)) (y      (gp-lookup y s)) 
190              (ns-x   ns)              (ns-y   #f) 
191              (lx?    lx?)             (ly?    #f)
192              (x-lex? lex?)            (y-lex? #f) (? #f) (s s))
193
194       (pp 'lp x y ns-x ns-y lx? ly? #:x-lex? x-lex? #:y-lex? y-lex?)
195
196       (cond
197        ((namespace? y)
198         (let ((ns-y2 (namespace-ns y))
199               (ly2?  (namespace-local? y))
200               (lex2? (namespace-lexical? y)))
201           (if (if (not ns-y) #f (comp-fail? ns-y ly? ns-y2 ly2? #f))
202               #f              
203               (lp x      (gp-lookup (namespace-val y) s)
204                   ns-x   ns-y2
205                   lx?    ly2?
206                   x-lex? lex2? #t s))))
207         
208        ((namespace? x)
209         (let ((ns-x2 (namespace-ns x))
210               (lx2?  (namespace-local? x))
211               (lex2? (namespace-lexical? x)))
212           (if (comp-fail? ns-x lx? ns-x2 lx2? #f)
213               #f
214               (if ?
215                   (lp (gp-lookup (namespace-val x) s) y
216                       ns-x2                           ns-y
217                       lx2?                            ly?
218                       lex2?                           y-lex? ? s)
219                   (lp (gp-lookup (namespace-val x) s) y
220                       ns-x2                           ns-x2
221                       lx2?                            lx2?
222                       lex2?                           lex2? ? s)))))
223                   
224
225        ((not ns-y)
226         (lp x      y
227             ns-x   ns-x
228             lx?    lx?
229             x-lex? #t ? s))
230            
231         
232        (else
233         (if (and (equal? ns-x ns-y) (eq? lx? ly?))
234             (cond
235              ((gp-var? x s)
236               (if (gp-var? y s)
237                   (if (and x-lex? y-lex? bang?)
238                       (let ((s (gp-set! x y s)))
239                         (gp-set! x (make-namespace (gp-var! s)
240                                                    ns-x lx? #f)
241                                  s))
242                       (if bang?
243                           (cond
244                            (x-lex?
245                             (gp-set! x (make-namespace y ns-x lx? #f) s))
246                            (y-lex?
247                             (gp-set! y (make-namespace x ns-y ly? #f) s))
248                            (else
249                             (gp-set! x y s)))
250                           (if (eq? x y)
251                               s
252                               #f)))
253                   (imprint! x y ns-x lx? x-lex? y-lex? s bang?)))
254                    
255              ((gp-var? y s)                    
256               (imprint! y x ns-y ly? y-lex? x-lex? s bang?))
257                    
258              ((or (vector? x) (vector? y))
259               (if (and (vector? x) (vector? y))
260                   (lp (vector->list x) (vector->list y) ns-x ns-y lx? ly? 
261                       x-lex? y-lex? ? s)
262                   #f))
263            
264              ((or (procedure? x) (procedure? y))
265               (if (eq? (procedure? x) (procedure? y))
266                   s
267                   #f))
268
269              ((or (prolog-closure? x) (prolog-closure? y))
270               (if (and (prolog-closure? x) (prolog-closure? y))
271                   (if (eq? (prolog-closure-parent x) 
272                            (prolog-closure-parent y))
273                       (lp (prolog-closure-state x)
274                           (prolog-closure-state y)
275                           ns-x ns-y lx? ly? x-lex? y-lex? ? s)
276                       (if (fluid-ref error-when-closed?)
277                           ((@@ (logic guile-log prolog closed) err)
278                            x y)
279                           #f))))
280            
281              (else
282               (umatch (#:mode - #:status s #:name 'ns-1) (x y)
283                       ((xa . xl) (ya . yl)
284                        (let lp-x ((s s) (x x) (y y))
285                          (umatch (#:mode - #:status s #:name 'ns-2) (x y)
286                            ((xa . xl) (ya . yl)
287                             (let ((s (lp (gp-lookup xa s)
288                                          (gp-lookup ya s)
289                                          ns-x ns-y lx? ly? 
290                                          x-lex? y-lex? ? s)))
291                               (if s
292                                   (lp-x s (gp-lookup xl s) (gp-lookup yl s))
293                                   s)))
294                                 
295                            (x        y
296                             (lp x y ns-x ns-y lx? ly? 
297                                 x-lex? y-lex? ? s)))))
298
299                       (x y
300                          (if (equal? x y) s #f)))))
301
302             #f))))))
303
304 (define (imprint! x y ns lx? lex? y-lex? s bang?)
305   (if (not bang?)
306       #f
307       (imprint!* x y ns lx? lex? y-lex? s)))
308 (define (imprint!* x y ns lx? lex? y-lex? s)
309   (define (unify x y s)
310     (gp-unify! x y s))
311
312   (define (check-proc proc)
313     (let ((name (procedure-name proc)))
314       (if name
315           (let ((modnm (procedure-property proc 'module)))
316             (if modnm
317                 (if (equal? ns modnm)
318                     (if lx?
319                         #t
320                         (module-defined? (module-public-interface 
321                                           (resolve-module ns))
322                                          name))
323                     #f)
324                 #f))
325           #f)))
326   
327   (let lp ((s s) (y (gp-lookup y s)) (x (gp-lookup x s)) (y-lex? y-lex?) 
328            (ns ns) (lx? lx?))
329     (pp 'imp y x)
330     (let ((f (lambda ()
331                (cond
332                 ((vector? y)
333                  (let* ((xx (gp-var! s))
334                         (ly (vector->list y))
335                         (lx (map (lambda (x) (gp-var! s)) ly)))
336                    (if y-lex?
337                        (lp s ly lx y-lex? ns lx?)
338                        (let ((s (validate y ns lx? s)))
339                          (if s
340                              (gp-set! x y s)
341                              #f)))))
342                          
343                 ((string? y)
344                  (let ((f (translate y ns lx?)))
345                    (if f
346                        (gp-set! x f s)
347                        #f)))
348                 
349                 ((prolog-closure? y)
350                  (if (check-proc (prolog-closure-parent y))
351                      (let*  ((xx (gp-var! s))
352                              (ly (prolog-closure-state y))
353                              (lx (map (lambda (x) (gp-var! s)) ly)))
354                        (if y-lex?
355                            (let ((s (lp s ly lx y-lex? ns lx?)))
356                              (if s                                   
357                                  (gp-set! x
358                                           (make-prolog-closure
359                                            (prolog-closure-closure y)
360                                            (prolog-closure-parent  y)
361                                            lx
362                                            (prolog-closure-closed? y))
363                                           s)
364                                  #f))
365                            (let ((s (validate (gp-lookup ly s)
366                                               ns lx? s)))
367                              (if s
368                                  (gp-set! x y s)
369                                  #f))))
370                      
371                      #f))
372                     
373                 ((procedure? y)
374                  (if (check-proc y)
375                      (gp-set! x y s)
376                      #f))
377                   
378              
379                 ((namespace? y)
380                  (let ((ns2  (namespace-ns y))
381                        (lx2? (namespace-local? y)))
382                    (if (comp-fail? ns lx? ns2 lx2? #t)
383                        #f
384                        (if (namespace-lexical? y)
385                            (lp s (namespace-val y) x #t ns2 lx2?)
386                            (let ((s (validate y ns2 lx2? s)))
387                              (if s
388                                  (gp-set! x y s)
389                                  #f))))))
390
391              
392
393                 ((gp-var? y s)
394                  (let ((s (gp-set! x y s)))
395                    (if y-lex?
396                        (gp-set! y
397                                 (make-namespace (gp-var! s) ns lx? #f)
398                                 s)
399                        s)))
400                 (else
401                  (gp-set! x y s))))))
402
403       (umatch (#:mode - #:status s #:name imprint!) (y)
404         ((yy . ly) 
405          (umatch (#:mode + #:status s #:name 'imprint2) (x)
406            ((xx . lx)        
407             (let ((s (lp s (gp-lookup yy s) (gp-lookup xx s) 
408                          y-lex? ns lx?)))
409               (if s
410                   (lp s (gp-lookup ly s) (gp-lookup lx s) 
411                       y-lex? ns lx?)
412                   s)))))
413
414         (_ (f))))))
415
416
417 (setup-namespace <namespace-type> ns-unify)