Coverage report: /development/source/library/org/datagraph/spocq-shard/src/utilities/view-graph.lisp

KindCoveredAll%
expression0217 0.0
branch010 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;
2
 
3
 (in-package :spocq.i)
4
 
5
 #|
6
 generate a flow graph for all of the views in a repository.
7
 |#
8
 
9
 (defvar *encode-view-graph.nodes* nil)
10
 
11
 (defgeneric encode-view-graph (source destination &rest options)
12
   (:method ((source t) (destination pathname) &rest options)
13
     (with-open-file (output destination :direction :output :if-does-not-exist :create :if-exists :supersede)
14
       (apply #'encode-view-graph source output options)))
15
   (:method ((source string) (destination t) &rest options)
16
     (apply #'encode-view-graph (repository source) destination options))
17
   
18
 
19
   (:method ((repository repository) (destination stream) &rest options &key attributes &allow-other-keys)
20
     (let ((*gensym-counter* 0)
21
           (setf.dot:*pretty* *print-pretty*)
22
           (*encode-view-graph.nodes* (make-hash-table :test 'equal))
23
           (result nil))
24
       (flet ((put-repository-views ()
25
                (setf result (apply #'encode-view-graph repository setf.dot:*context* options))))
26
         (destructuring-bind (&key (rankdir "LR") (fontname "courier")
27
                                   (edge '(:fontname "courier"))
28
                                   (node '(:fontname "courier"))
29
                                   &allow-other-keys) attributes
30
           (apply #'dot:context-put-graph (make-instance 'setf.dot:stream :stream destination)
31
                  (repository-id repository) #'put-repository-views
32
                  :rankdir rankdir
33
                  :fontname fontname
34
                  :edge edge
35
                  :node node
36
                  :label (repository-id repository)
37
                  attributes)
38
           result))))
39
 
40
   (:method ((repository repository) (dot-context setf.dot:stream) &rest options &key view-names &allow-other-keys)
41
     (unless (gethash (repository-identifier repository) *encode-view-graph.nodes*)
42
       (setf (gethash (repository-identifier repository) *encode-view-graph.nodes*) repository)
43
       (let ((views (repository-view-definitions repository)))
44
         (dot:context-put-node dot-context (repository-identifier repository)
45
                               :label (repository-id repository)
46
                               :shape "box")
47
         (loop for view in views
48
           when (or (null view-names) (find (view-name view) view-names :test #'string-equal))
49
           do (apply #'encode-view-graph view dot-context options)
50
           and collect (view-name view)))))
51
 
52
   (:method ((source view) (dot-context setf.dot:stream) &rest options &key attributes &allow-other-keys)
53
     (unless (gethash (view-identifier source) *encode-view-graph.nodes*)
54
       (setf (gethash (view-identifier source) *encode-view-graph.nodes*) source)
55
       (let* ((name (view-name source))
56
              (id (view-identifier source))
57
              (repository (view-repository source))
58
              (expression (ignore-errors (parse-sparql (view-query source))))
59
              (service-clauses (expression-service-forms expression))
60
              (project-clauses (expression-select-forms expression))
61
              (variable-predicates (loop for (nil nil p o) in (expression-pattern-statements expression)
62
                                     collect (cons o p)))
63
              (is-input-query (and (construct-form-p expression)
64
                                   (expression-table-forms expression)))
65
              #+(or) ;; this would request the view
66
              (url (iri-lexical-form (resource-uri source)))
67
              (url (let* ((url (iri-lexical-form (resource-uri source)))
68
                          (last (position #\/ url :from-end t)))
69
                     (concatenate 'string (subseq url 0 (1+ last)) "@query#" (subseq url (1+ last))))))
70
         (destructuring-bind (&key (rankdir "LR") &allow-other-keys) attributes
71
           (dot:context-put-node dot-context id
72
                                 :label name
73
                                 :url url)
74
           (when expression
75
             (if is-input-query
76
                 (dot:context-put-edge dot-context id (repository-identifier repository))
77
                 (dot:context-put-edge dot-context (repository-identifier repository) id))
78
             (loop for (op location . rest) in service-clauses
79
               do (let ((service-repository (ignore-errors (service-repository location))))
80
                    (typecase service-repository
81
                      ((or null service-repository)
82
                       (dot:context-put-node dot-context (iri-lexical-form location)
83
                                             :label (iri-lexical-form location)
84
                                             :shape "box")
85
                       (dot:context-put-edge dot-context id (iri-lexical-form location)))
86
                      (t
87
                       (apply #'encode-view-graph service-repository dot-context options)
88
                       (dot:context-put-edge dot-context id  (repository-identifier service-repository))))))
89
             (loop for (op form dimensions) in project-clauses
90
               do (let ((record-text (format nil
91
                                             (if (equalp rankdir "LR") "~{~a~^|~}" "{~{~a~^|~}}")
92
                                             (loop for dimension in dimensions
93
                                               for iri = (rest (assoc dimension variable-predicates))
94
                                               collect (typecase iri
95
                                                         (iri (format nil "~a (~a)" dimension (iri-lexical-form iri)))
96
                                                         (null dimension)
97
                                                         (t (substitute-if #\_
98
                                                                           #'(lambda (c) (find c "<>{}"))
99
                                                                           (format nil "~a (~a)" dimension iri)))))))
100
                        (api (symbol-name (gensym "dialog"))))
101
                    (dot:context-put-node dot-context api
102
                                          :label record-text
103
                                          :shape "record")
104
                    (if is-input-query
105
                        (dot:context-put-edge dot-context api id)
106
                        (dot:context-put-edge dot-context id api))))))))))
107
 
108
 #+(or)
109
 (
110
  (in-package :spocq.i)
111
  (initialize-spocq)
112
 
113
  ;; nl4
114
  (spocq.i::repository-view-definitions (repository "james/cms"))
115
  (encode-view-graph "james/cms" #p"/tmp/cms.dot" ())
116
  (spocq.i::repository-view-definitions (repository "fbfpt/sensors"))
117
  (spocq.i::repository-view-definitions (repository "fbfpt/kombuchadata"))
118
  (encode-view-graph "fbfpt/sensors" #p"/tmp/fbfpt.sensors.dot")
119
  (encode-view-graph "fbfpt/kombuchadata" #p"/tmp/fbfpt.kombuchadata.dot")
120
  (encode-view-graph "fbfpt/kombuchadata" #p"/tmp/fbfpt.kombuchadata-some.dot" :view-names '("firstbatchsugar" "startercultureph"))
121
 
122
  ;; nl8
123
  (encode-view-graph "nxp/plm" #p"/tmp/plm.dot" '(:rankdir "TB"))
124
 
125
  ;; nl11
126
  (encode-view-graph "nexperia/plm" #p"/tmp/nexperia-plm-selection.dot" :view-names '("qcm_cn_details"
127
                                                                                      "qcm_cn_gac"
128
                                                                                      "qcm_cn_products"
129
                                                                                      "qcm_cn_pta1"
130
                                                                                      "qcm_cn_pta2"
131
                                                                                      "qcm_company"
132
                                                                                      ))
133
 )