/
emf.clj
1739 lines (1534 loc) · 59.2 KB
/
emf.clj
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(ns funnyqt.emf
"Core functions for accessing and manipulating EMF models."
(:require [clojure.core.cache :as cache]
[clojure.core.reducers :as r]
[clojure.string :as str]
[funnyqt.generic :as g]
[funnyqt.internal :as i]
[funnyqt.utils :as u]
[funnyqt.query :as q]
[flatland.ordered.set :as os]
[flatland.ordered.map :as om]
inflections.core)
(:import
(org.eclipse.emf.ecore.xmi.impl XMIResourceImpl XMIResourceFactoryImpl)
(org.eclipse.emf.ecore.util EcoreUtil)
(org.eclipse.emf.common.util URI EList UniqueEList EMap)
(org.eclipse.emf.ecore.resource Resource ResourceSet Resource$Factory$Registry)
(org.eclipse.emf.ecore.resource.impl ResourceSetImpl ResourceFactoryRegistryImpl)
(org.eclipse.emf.ecore
EcorePackage EPackage EPackage$Registry EObject EModelElement EClassifier
EClass EDataType EEnumLiteral EEnum EFactory ETypedElement EAnnotation
EAttribute EReference EStructuralFeature)))
;;# Simple type predicates
(defn eobject?
"Returns true if `eo` is an EObject."
{:inline (fn [x] `(instance? EObject ~x))}
[eo]
(instance? EObject eo))
(extend-protocol g/IElement
EObject
(element? [this] true))
(defn eclass?
"Returns true if `ec` is an EClass."
{:inline (fn [x] `(instance? EClass ~x))}
[ec]
(instance? EClass ec))
(defn epackage?
"Returns true if `ep` is an EPackage."
{:inline (fn [x] `(instance? EPackage ~x))}
[ep]
(instance? EPackage ep))
(defn ereference?
"Returns true if `er` is an EReference."
{:inline (fn [x] `(instance? EReference ~x))}
[er]
(instance? EReference er))
(defn eattribute?
"Returns true if `ea` is an EAttribute."
{:inline (fn [x] `(instance? EAttribute ~x))}
[ea]
(instance? EAttribute ea))
(defn eproxy?
"Returns true if `eo` is a proxy EObject."
[eo]
(and (eobject? eo)
(.eIsProxy ^EObject eo)))
;;# Metamodel Access
(def ^:dynamic ^EPackage$Registry *epackage-registry*
"The current EPackage Registry which is used for EClassifier registration and
lookup. The default value is the global registry. Use
(with-epackage-registry (.getPackageRegistry my-resource-set)
...)
to use a ResourceSet's local registry instead."
EPackage$Registry/INSTANCE)
(defmacro with-epackage-registry
"Evaluate `body` with the current value of *epackage-registry* set to
`registry`."
[registry & body]
`(binding [*epackage-registry* ~registry]
~@body))
(def ^:dynamic *ns-uris*
"A set of namespace URIs to which the classifier lookup should be restricted.
Also see `with-ns-uris'."
nil)
(defmacro with-ns-uris
"Restricts the EClassifier lookup in the dynamic scope of `body` to those
contained in top-level EPackages registered with the given namespace `uris`
at the EPackage registry and subpackages thereof."
{:arglists '([[uris] & body])}
[uris & body]
`(binding [*ns-uris* ~uris]
~@body))
(def ^:private registry-access-classloader (ClassLoader/getSystemClassLoader))
(defn set-registry-access-classloader! [cl]
(if (instance? ClassLoader cl)
(alter-var-root #'registry-access-classloader (constantly cl))
(u/errorf "Can't set registry-access-classloader to non ClassLoader value %s" cl)))
(defmacro ^:private with-registry-access-classloader [& body]
`(let [^Thread curt# (Thread/currentThread)
curcl# (.getContextClassLoader curt#)]
(if (= curcl# registry-access-classloader)
(do ~@body)
(do
(.setContextClassLoader curt# registry-access-classloader)
(try
~@body
(finally (.setContextClassLoader curt# curcl#)))))))
;; Caches
(defrecord ^:private CacheEntry [ns-uris spec])
(alter-meta! #'->CacheEntry assoc :private true)
(alter-meta! #'map->CacheEntry assoc :private true)
(defmacro ^:private make-cache-entry [ns-uris nm]
`(CacheEntry. (or ~ns-uris *ns-uris*) ~nm))
(def ^:private +eclassifier-cache+
"A cache from EClassifier names to EClassifiers."
(cache/soft-cache-factory (hash-map)))
(def ^:private +type-matcher-cache+
"A cache from type-specs to type-matchers."
(cache/soft-cache-factory (hash-map)))
(defn ^:private reset-all-emf-caches
"Resets all EMF specific caches:
1. the +eclassifier-cache+
2. the +type-matcher-cache+"
[]
(alter-var-root #'+eclassifier-cache+
(constantly (cache/soft-cache-factory (hash-map))))
(alter-var-root #'+type-matcher-cache+
(constantly (cache/soft-cache-factory (hash-map)))))
(defn esubpackages
"Returns all direct subpackages of EPackage `ep`."
[^EPackage ep]
(seq (.getESubpackages ep)))
(defn eallsubpackages
"Returns all direct and indirect subpackages of EPackage `ep`."
[^EPackage ep]
(let [subs (esubpackages ep)]
(concat subs (mapcat esubpackages subs))))
(defn epackages
"The lazy seq of all registered EPackages and their subpackages."
[]
(with-registry-access-classloader
(map (fn [uri]
(if-let [p (.getEPackage *epackage-registry* uri)]
p
(u/errorf "No such EPackage nsURI: %s" uri)))
(or *ns-uris* (.keySet *epackage-registry*)))))
(defn ^:private ns-uris-and-type-spec [name]
(if (map? name)
(if (== (count name) 1)
(let [[ns-uris n :as tup] (first name)]
(if (coll? ns-uris)
tup
[[ns-uris] n]))
(u/errorf "Broken type spec: %s" name))
[nil name]))
(defn epackage
"Returns the EPackage with the given (simple or qualified) `name`.
In case there are several packages with the same (qualified) name, you can
also disambiguate using {\"http://ns/uri\" pkg-name}, or by using
`with-ns-uris`."
[name]
(let [[ns-uris name] (ns-uris-and-type-spec name)]
(binding [*ns-uris* (if ns-uris ns-uris *ns-uris*)]
(let [name (clojure.core/name name)
ffn (if (.contains name ".")
(fn [^EPackage p] (= (clojure.core/name (g/qname p)) name))
(fn [^EPackage p] (= (.getName p) name)))
qkgs (filter ffn (epackages))]
(when-not (seq qkgs)
(u/errorf "No such package %s." name))
(when (nnext qkgs)
(u/errorf "Multiple packages named %s: %s\n%s%s" name qkgs
"Restrict the search space using `with-ns-uris` "
"or use {\"http://ns/uri\" pkg-name}."))
(first qkgs)))))
(extend-protocol g/IMMAbstract
EClass
(mm-abstract? [this]
(.isAbstract this)))
(extend-protocol g/IUnset
EObject
(unset? [this attr]
(not (.eIsSet this (.getEStructuralFeature (.eClass this) (name attr))))))
(defn eclassifiers
"Returns the lazy seq of EClassifiers known by *epackage-registry*.
Also see: `with-ns-uris` and `with-epackage-registry`."
[]
(sequence (mapcat (fn [^EPackage ep]
(.getEClassifiers ep)))
(epackages)))
(defn eclass
"Returns the EClass of the given EObject `eo`."
^org.eclipse.emf.ecore.EObject [^EObject eo]
(.eClass eo))
(declare eallcontents)
(defn eclasses
"Returns the lazy seq of EClasses known by *epackage-registry*.
Also see: `with-ns-uris` and `with-epackage-registry`"
([]
(filter eclass? (eclassifiers)))
([ecore-resource]
(filter eclass? (eallcontents ecore-resource))))
(defn eclassifier
"Returns the eclassifier with the given `name`.
`name` may be a simple, qualified name, or a map of the form {nsURI name}.
In the latter case, the lookup is restricted to the package with the given
nsURI (and its subpackages).
Throws an exception if no such classifier could be found, or if the given
simple name is ambiguous.
Also see: `with-ns-uris` and `with-epackage-registry`"
[name]
(let [[ns-uris nm] (ns-uris-and-type-spec name)
cache-entry (make-cache-entry ns-uris nm)]
(if-let [ec (cache/lookup +eclassifier-cache+ cache-entry)]
(do (cache/hit +eclassifier-cache+ cache-entry) ec)
(binding [*ns-uris* (if ns-uris ns-uris *ns-uris*)]
(let [^String n (clojure.core/name nm)
ld (.lastIndexOf n ".")]
(if (>= ld 0)
(let [^EPackage ep (epackage (subs n 0 ld))]
(or (.getEClassifier ep (subs n (inc ld)))
(u/errorf "No such EClassifier %s in %s." n (print-str ep))))
(let [classifiers (filter (fn [^EClassifier ec]
(= (.getName ec) n))
(eclassifiers))]
(cond
(empty? classifiers) (u/errorf "No such EClassifier %s." n)
(next classifiers) (u/errorf "EClassifier %s is ambiguous: %s\n%s%s"
n (print-str classifiers)
"Restrict the search space using `with-ns-uris` "
"or by using {\"http://ns/uri\" qname}.")
:else (let [ec (first classifiers)]
(cache/miss +eclassifier-cache+ cache-entry ec)
ec)))))))))
(defn esuperclasses
"Returns the direct super classes of the given EClass `ec`."
[^EClass ec]
(into #{} (.getESuperTypes ec)))
(defn eallsuperclasses
"Returns the direct and indirect super classes of the given EClass `ec`."
[^EClass ec]
(into #{} (.getEAllSuperTypes ec)))
(defn esubclasses
"Returns the direct sub-EClasses of the given EClass `ec`."
[^EClass ec]
(into #{} (filter #(contains? (esuperclasses %) ec) (eclasses))))
(defn eallsubclasses
"Returns the direct and indirect sub-EClasses of the given EClass `ec`."
[^EClass ec]
(into #{} (filter #(and (not= ec %) (.isSuperTypeOf ec %)) (eclasses))))
(defn eenum-literal
"Returns the EEnumLiteral specified by its `qname`."
[qname]
(let [[eenum elit] (u/split-qname qname)]
(if-let [^EEnum enum-cls (eclassifier eenum)]
(if-let [^EEnumLiteral lit (.getEEnumLiteral enum-cls ^String elit)]
(or (.getInstance lit) lit)
(u/errorf "%s has no EEnumLiteral with name %s."
(print-str enum-cls) elit))
(u/errorf "No such EEnum %s." eenum))))
(extend-protocol g/IMMAllSubclasses
EClass
(mm-all-subclasses [this]
(eallsubclasses this)))
(extend-protocol g/IEnumConstant
EObject
(enum-constant [el const]
(eenum-literal const))
Resource
(enum-constant [el const]
(eenum-literal const))
nil
(enum-constant [el const]
(eenum-literal const)))
;;# Generic Metamodel Access
(extend-protocol g/IMMElementClasses
EClass
(mm-element-classes [cls]
(if-let [r (.eResource cls)]
(eallcontents r 'EClass)
(let [top-pkg (loop [^EPackage p (.getEPackage cls)]
(if-let [sup (.getESuperPackage p)]
(recur sup)
p))
subs (eallsubpackages top-pkg)
uris (into [] (comp (map #(.getNsURI ^EPackage %))
(remove nil?))
(cons top-pkg subs))]
(with-ns-uris uris
(eclasses)))))
Resource
(mm-element-classes [res]
(eclasses res))
ResourceSet
(mm-element-classes [rs]
(eclasses rs)))
(extend-protocol g/IMMClass
EClass
(mm-class? [this] true)
EObject
(mm-class? [this] false)
(mm-class
([this]
(.eClass this))
([this qn]
(eclassifier qn)))
ResourceSet
(mm-class? [this] false)
(mm-class
([this qn]
(eclassifier qn)))
Resource
(mm-class? [this] false)
(mm-class
([this qn]
(eclassifier qn))))
(extend-protocol g/IMMDirectSuperclasses
EClass
(mm-direct-superclasses [this]
(seq (.getESuperTypes this))))
(extend-protocol g/IMMSuperclass
EClass
(mm-superclass? [this sub]
(and (not (identical? this sub))
(.isSuperTypeOf this sub))))
(extend-protocol g/IMMAttributes
EClass
(mm-attributes [cls]
(map (fn [^EAttribute attr]
(keyword (.getName attr)))
(.getEAttributes cls))))
(extend-protocol g/IMMReferences
EClass
(mm-references [cls]
(map (fn [^EReference ref]
(keyword (.getName ref)))
(.getEReferences cls))))
(extend-protocol g/IMMReferencedElementClass
EClass
(mm-referenced-element-class [this ref]
(if-let [^EStructuralFeature sf (.getEStructuralFeature this (name ref))]
(if (instance? EReference sf)
(.getEReferenceType ^EReference sf)
(u/errorf "%s is no EReference." sf))
(u/errorf "No such structural feature %s at EClass %s." ref this))))
(extend-protocol g/IMMBooleanAttribute
EClass
(mm-boolean-attribute? [ec attr]
(let [^EAttribute ea (.getEStructuralFeature ec (name attr))]
(= "EBoolean" (.getName (.getEAttributeType ea))))))
(extend-protocol g/IMMMultiValuedProperty
EClass
(mm-multi-valued-property? [cls prop]
(.isMany (.getEStructuralFeature cls (name prop)))))
(extend-protocol g/IMMContainmentReference
EClass
(mm-containment-reference? [this ref-kw]
(if-let [^org.eclipse.emf.ecore.EReference
er (.getEStructuralFeature this (name ref-kw))]
(.isContainment er)
(u/errorf "No such reference %s at metamodel class %s." ref-kw this))))
;;# Model
;;## Qualified Names
(extend-protocol g/IQualifiedName
EClassifier
(qname [this]
(if-let [pkg (.getEPackage this)]
(symbol (str (g/qname pkg)
"." (.getName this)))
(symbol (.getName this))))
EPackage
(qname [this]
(loop [p (.getESuperPackage this), n (.getName this)]
(if p
(recur (.getESuperPackage p) (str (.getName p) "." n))
(symbol n))))
EObject
(qname [o]
(g/qname (.eClass o))))
(extend-protocol g/IUniqueName
EClassifier
(uname [ec]
(let [n (.getName ec)
ecs (filter (fn [^EClass e]
(= n (.getName e)))
(eclassifiers))]
(if (> (count ecs) 1)
(g/qname ec)
(symbol n))))
EObject
(uname [eo]
(g/uname (.eClass eo))))
;;## EMF Resources
(defn ^:private create-uri [f]
;; We always use createFileURI because proxy resolution doesn't work if we
;; just use createURI.
(cond
(instance? URI f)
f
(instance? java.io.File f)
(URI/createFileURI (.getAbsolutePath ^java.io.File f))
(instance? java.net.URL f)
(URI/createURI (.toString ^java.net.URI (.toURI ^java.net.URL f)))
(clojure.java.io/resource f)
(create-uri (clojure.java.io/resource f))
(string? f)
(create-uri (clojure.java.io/file f))
:else (u/errorf "Cannot create URI for %s." f)))
(defn new-resource
"Creates and returns a new, empty Resource.
If ResourceSet `rs` and `uri` are given, then create a new Resource with that
URI in the ResourceSet."
(^org.eclipse.emf.ecore.resource.Resource
[] (XMIResourceImpl.))
(^org.eclipse.emf.ecore.resource.Resource
[^ResourceSet rs uri]
(.createResource rs (create-uri uri))))
(defn new-resource-set
"Creates and returns a new ResourceSet.
This resource set assumes any resources in it are XMIResources."
^org.eclipse.emf.ecore.resource.ResourceSet
[]
(doto (ResourceSetImpl.)
(.setResourceFactoryRegistry
(let [rfr (ResourceFactoryRegistryImpl.)
extmap (.getExtensionToFactoryMap rfr)
cntmap (.getContentTypeToFactoryMap rfr)
rf (XMIResourceFactoryImpl.)]
(.put extmap Resource$Factory$Registry/DEFAULT_EXTENSION rf)
(.put cntmap Resource$Factory$Registry/DEFAULT_CONTENT_TYPE_IDENTIFIER rf)
rfr))))
(defn load-resource
"Loads an EMF resource from the XMI file `f`.
`f` may be a file name given as string, a java.io.File, an URI, or a
java.net.URL. `additional-opts` may be additional many option-value pairs
that are added to the default load options.
Also see `load-ecore-resource`."
[f & additional-opts]
(let [uri (create-uri f)
res (XMIResourceImpl. uri)
opts (.getDefaultLoadOptions res)]
(doseq [[opt val] (apply hash-map additional-opts)]
(.put opts opt val))
(.load res opts)
res))
(defn get-resource
"Returns the Resource with the given `uri` contained in ResourceSet `rs`.
See ResourceSet.getResource(URI, boolean)"
^org.eclipse.emf.ecore.resource.Resource
[^ResourceSet rs uri load-on-demand]
(.getResource rs (create-uri uri) load-on-demand))
(defn ^:private register-epackages
"Registeres the given packages at the EPackage$Registry by their nsURI.
Skips packages that are already registered."
[pkgs]
(with-registry-access-classloader
(doseq [^EPackage p pkgs]
(when-let [uri (.getNsURI p)]
(when (seq uri)
(when-not (.containsKey *epackage-registry* uri)
(.put *epackage-registry* uri p)))))))
(defn ^:private all-epackages-in-resource [^Resource r]
(let [ps (filter #(instance? EPackage %) (.getContents r))]
(concat ps (mapcat eallsubpackages ps))))
(defn load-ecore-resource
"Loads an Ecore model from the ecore file `f`.
All EPackages are registered at the *epackage-registry* which defaults to the
global registry. The Ecore model is returned as a Resource. `f` may be a
file name given as string, a java.io.File, an URI, or a java.net.URL. Also
see `with-epackage-registry`."
[f]
;; Reset the caches, since now the names might not be unique anymore.
(reset-all-emf-caches)
(let [res (load-resource f)]
(register-epackages
(all-epackages-in-resource res))
res))
(alter-var-root #'g/mm-load-handlers assoc #".*\.ecore$" load-resource)
;; FIXME: That's actual a workaround for a misfeature of EMF. See
;; http://www.eclipse.org/forums/index.php/m/405881/
(defn ^:private fixup-resource [^Resource resource]
(let [l (.getContents resource)
^java.util.ListIterator li (.listIterator l)]
(while (.hasNext li)
(let [^EObject o (.next li)]
(when (.eContainer o)
(.remove li))))
resource))
(defn save-resource
"Saves the given `resource`. If given a file `f`, saves to it.
`f` may be a file name given as string, a java.io.File, an URI, or a
java.net.URL."
([^Resource resource]
(if-let [uri (.getURI resource)]
(do
(fixup-resource resource)
(println "Saving resource to" (.toFileString uri))
(.save resource nil))
(u/error (str "You tried to call save-resource on a Resource not associated "
"with a file!\n"))))
([^Resource resource f]
(let [uri (create-uri f)]
(.setURI resource uri)
(save-resource resource))))
;;## Type Checks
(defn ^:private type-matcher-emf-1
"Returns a matcher for elements Foo, !Foo, Foo!, !Foo!."
[c]
(let [v (u/type-with-modifiers (name c))
neg (v 0)
qname (v 1)
exact (v 2)
^EClassifier type (eclassifier qname)]
(if neg
(if exact
(fn [^EClass x] (not (identical? type (.eClass x))))
(fn [^EClass x] (not (.isInstance type x))))
(if exact
(fn [^EClass x] (identical? type (.eClass x)))
(fn [^EClass x] (.isInstance type x))))))
(defn ^:private type-matcher-emf
[ts]
(cond
(nil? ts) identity
(u/qname? ts) (type-matcher-emf-1 ts)
(vector? ts) (if (seq ts)
(let [f (first ts)
[op r] (case f
:and [q/and-fn (next ts)]
:nand [q/nand-fn (next ts)]
:or [q/or-fn (next ts)]
:nor [q/nor-fn (next ts)]
:xor [q/xor-fn (next ts)]
[q/or-fn ts])
t-matchers (map #(type-matcher-emf %) r)]
(apply op t-matchers))
;; Empty collection given: (), [], that's also ok
identity)
(fn? ts) ts
;; {"http://my.nsuri/1.0" ts}
(map? ts) (let [[ns-uris ts] (first ts)]
(binding [*ns-uris* (if ns-uris [ns-uris] *ns-uris*)]
(type-matcher-emf ts)))
(eclass? ts) (fn [e] (.isInstance ^EClass ts e))
:else (u/errorf "Don't know how to create an EMF type-matcher for %s" ts)))
(defn ^:private type-matcher-cached [_ ts]
(let [[ns-uris ts-1] (ns-uris-and-type-spec ts)
cache-entry (make-cache-entry ns-uris ts-1)]
(if-let [tm (cache/lookup +type-matcher-cache+ cache-entry)]
(do (cache/hit +type-matcher-cache+ cache-entry) tm)
(let [tm (type-matcher-emf ts)]
(cache/miss +type-matcher-cache+ cache-entry tm)
tm))))
(extend-protocol g/ITypeMatcher
EObject
(type-matcher [m ts]
(type-matcher-cached m ts))
Resource
(type-matcher [m ts]
(type-matcher-cached m ts))
ResourceSet
(type-matcher [m ts]
(type-matcher-cached m ts)))
(extend-protocol g/IInstanceOf
EObject
(is-instance? [object class]
(and (eclass? class)
(.isInstance ^EClass class object))))
;;## Traversal Stuff
(defprotocol ^:private IEContents
"A protocol for getting the contents of Resources, ResourceSets and EObjects."
(^:private eallcontents-internal [this tm]
"Returns a seq of all directly and indirectly contained EObjects whose type
matches the type spec `ts` (see `funnyqt.generic/type-matcher`).")
(^:private econtents-internal [this tm]
"Returns a seq of all directly contained EObjects whose type matches the
type spec `ts` (see `funnyqt.generic/type-matcher`)."))
(extend-protocol IEContents
EObject
(econtents-internal [this ts]
(sequence (filter (g/type-matcher this ts))
(seq (.eContents this))))
(eallcontents-internal [this ts]
(sequence (filter (g/type-matcher this ts))
(iterator-seq
(EcoreUtil/getAllProperContents this true))))
Resource
(econtents-internal [this ts]
(sequence (filter (g/type-matcher this ts))
(seq (.getContents this))))
(eallcontents-internal [this ts]
(sequence (filter (g/type-matcher this ts))
(iterator-seq
(EcoreUtil/getAllProperContents this true))))
ResourceSet
(eallcontents-internal [this ts]
(sequence (comp (filter eobject?)
(filter (g/type-matcher this ts)))
(iterator-seq
(EcoreUtil/getAllProperContents this true))))
clojure.lang.IPersistentCollection
(econtents-internal [this tm]
(sequence (mapcat #(econtents-internal % tm))
this))
(eallcontents-internal [this tm]
(sequence (mapcat #(eallcontents-internal % tm))
this)))
(defn eallcontents
"Returns a lazy seq of `container`s direct and indirect contents
matching the type spec `ts`. `container` may be an EObject, a
Collection, a Resource, or a ResourceSet."
([container]
(eallcontents-internal container identity))
([container ts]
(eallcontents-internal container ts)))
(defn econtents
"Returns a lazy seq of `containers`s direct contents matching the type spec `ts`.
`container` may be an EObject, a Collection, a Resource, or a
ResourceSet."
([container]
(econtents-internal container identity))
([container ts]
(econtents-internal container ts)))
(extend-protocol g/IElements
Resource
(elements
([this]
(eallcontents this))
([this ts]
(eallcontents this ts)))
ResourceSet
(elements
([this]
(eallcontents this))
([this ts]
(eallcontents this ts))))
(defn eresource
"Returns the Resource containing `eo` directly or indirectly (if any)."
^org.eclipse.emf.ecore.resource.Resource [^EObject eo]
(.eResource eo))
(defn ^:private eref-matcher
"Returns a reference matcher for the reference spec `rs`.
A reference matcher is a function of arity one that gets an EReference and
returns logical true if that ref should be accepted, false otherwise.
Semantics depend on `rs`:
nil => accept all references
someERef => accept only this EReference
:foo => accept only references named foo
[:foo :bar] => accept both foo and bar refs
(fn [r] ...) => simply use that"
[rs]
(cond
(nil? rs) identity
(fn? rs) rs
(u/prop-name? rs) (let [n (name rs)]
(fn [^EReference ref]
(= n (.getName ref))))
(ereference? rs) (fn [r] (= rs r))
(coll? rs) (if (seq rs)
(apply some-fn (map eref-matcher rs))
;; Empty collection given: (), [], that's also ok
identity)
:else (u/errorf "Don't know how to create a reference matcher for %s" rs)))
(defn ^:private get-eref ^EReference [^EClass ec n pred]
(if-let [^EStructuralFeature sf (.getEStructuralFeature ec (name n))]
(do
(when-not (instance? EReference sf)
(u/errorf "%s is no EReference." sf))
(if pred
(when (pred sf)
sf)
sf))
(u/errorf "No such EReference %s." n)))
(defn econtainer
"Returns the EObject containing `eo` (if any).
If a reference spec `rs` is given, return only `eo`s container if it's
referenced by a containment reference matching `rs`."
([^EObject eo]
(.eContainer eo))
([^EObject eo rs]
(if rs
(if (keyword? rs)
(when-let [ref (get-eref (.eClass eo) rs (fn [^EReference ref]
(.isContainer ref)))]
(.eGet eo ref))
(let [rm (eref-matcher rs)]
(first (sequence (comp (filter (and (.isContainer ^EReference ref)
(rm ref)))
(map (fn [^EReference r] (.eGet eo r))))
(seq (.getEAllReferences (.eClass eo)))))))
;; We cannot handle the rs = nil case with the above because it is
;; possible that there is no reference at all at the container side.
(.eContainer eo))))
(extend-protocol g/IContainer
EObject
(container
([this]
(econtainer this))
([this rs]
(econtainer this rs))))
(defn ^:private eopposite-refs
"Returns the seq of `eo`s EClass' references whose opposites match `src-rm`.
Example:
[Foo] f --- b [Bar]
f \\
`---- c [Car]
Given a Foo object and a eref-matcher matching f, returns a seq of the
EReferences b and c, because those are the opposites of the matched f. Of
course, if `src-rm` matches only one specific EReference, i.e., it was
constructed by (eref-matcher fERef) and not (eref-matcher :f), then only b
or c (exclusive) is returned.."
[^EObject eo src-rm]
(seq (sequence (comp (map (fn [^EReference r]
(when-let [o (.getEOpposite r)]
(when (src-rm o) r))))
(remove nil?))
(seq (-> eo .eClass .getEAllReferences)))))
(defn ^:private search-ereferencers
"Returns the seq of objects referencing `refed` by a reference matching `rm`
that are contained in `container`. `reffn` is either erefs or ecrossrefs."
[refed reffn rm container]
(filter (fn [o] (q/member? refed (reffn o rm)))
(if (coll? container) container (eallcontents container))))
(defn erefs
"Returns a set of EObjects referenced by EObject `eo`, possibly restricted by
the reference spec `rs`. For the syntax and semantics of `rs`, see
`eref-matcher`. In contrast to `ecrossrefs`, this function doesn't ignore
containment refs."
([eo]
(erefs eo nil))
([^EObject eo rs]
(if (keyword? rs)
(when-let [ref (get-eref (.eClass eo) rs nil)]
(when-let [x (.eGet eo ref)]
(if (.isMany ref) x #{x})))
(let [rm (eref-matcher rs)]
(into []
(comp (filter rm)
(mapcat (fn [^EReference r]
(when-let [x (.eGet eo r)]
(if (.isMany r) x [x])))))
(seq (-> eo .eClass .getEAllReferences)))))))
(defn ecrossrefs
"Returns a collection of EObjects cross-referenced by EObject`eo`, possibly
restricted by the reference spec `rs`. For the syntax and semantics of `rs`,
see `eref-matcher`. In EMF, crossrefs are all non-containment refs."
([eo]
(ecrossrefs eo nil))
([^EObject eo rs]
(if (keyword? rs)
(when-let [ref (get-eref (.eClass eo) rs (fn [^EReference ref]
(and (not (.isContainment ref))
(not (.isContainer ref)))))]
(when-let [x (.eGet eo ref)]
(if (.isMany ref) x #{x})))
(let [rm (eref-matcher rs)]
(into []
(comp (filter (fn [^EReference r]
(and (not (.isContainment r))
(not (.isContainer r))
(rm r))))
(mapcat (fn [^EReference r]
(when-let [x (.eGet eo r)]
(if (.isMany r) x [x])))))
(seq (-> eo .eClass .getEAllReferences)))))))
(defn econtentrefs
"Returns a collection of EObjects contained by EObject`eo`, possibly
restricted by the reference spec `rs`. For the syntax and semantics of `rs`,
see `eref-matcher`."
([eo]
(econtentrefs eo nil))
([^EObject eo rs]
(if (keyword? rs)
(when-let [ref (get-eref (.eClass eo) rs (fn [^EReference ref]
(.isContainment ref)))]
(when-let [x (.eGet eo ref)]
(if (.isMany ref) x #{x})))
(let [rm (eref-matcher rs)]
(into []
(comp (filter (fn [^EReference r]
(and (.isContainment r)
(rm r))))
(mapcat (fn [^EReference r]
(when-let [x (.eGet eo r)]
(if (.isMany r) x [x])))))
(seq (-> eo .eClass .getEAllReferences)))))))
(extend-protocol g/IContents
EObject
(contents
([this]
(econtents this))
([this ts-or-role]
(if (symbol? ts-or-role)
(econtents this ts-or-role)
(econtentrefs this ts-or-role)))))
(defn inv-erefs
"Returns the seq of EOjects that reference EObject `eo` with an EReference
matching `rs` (see `eref-matcher`). If no `container` is given, then only
check the opposite refs of `eo`. Else, all objects in `container` are tested
if they reference `eo`. `container` may be either an EObject, a Resource,
a ResourceSet, or a collection of EObjects. For the former three, direct and
indirect contents are checked, for collections only direct contents."
([eo]
(inv-erefs eo nil nil))
([eo rs]
(inv-erefs eo rs nil))
([eo rs container]
(let [rm (eref-matcher rs)]
(if container
(search-ereferencers eo erefs rm container)
(if-let [opposites (eopposite-refs eo rm)]
(erefs eo (eref-matcher opposites))
(u/error "No opposite EReferences found."))))))
(defn inv-ecrossrefs
"Returns the seq of EOjects that cross-reference EObject `eo` with an
EReference matching `rs` (see `eref-matcher`). If no `container` is given,
then only check the opposite refs of `eo`. Else, all objects in `container`
are tested if they cross-reference `eo`. `container` may be either an
EObject, a Resource, a ResourceSet, or a collection of EObjects. For the
former three, direct and indirect contents are checked, for collections only
direct contents."
([eo]
(inv-ecrossrefs eo nil nil))
([eo rs]
(inv-ecrossrefs eo rs nil))
([eo rs container]
(let [rm (eref-matcher rs)]
(if container
(search-ereferencers eo ecrossrefs rm container)
(if-let [opposites (eopposite-refs eo rm)]
(ecrossrefs eo (eref-matcher opposites))
(u/error "No opposite EReferences found."))))))
(defprotocol ^:private IEMFValues2ClojureValues
(^:private emf2clj-internal [this]
"Converts an EMF thingy to a clojure thingy.
EMF Type | Clojure Type
-------------+-------------
UniqueEList | ordered-set
EMap | ordered-map
EList | vector
All other objects are kept as-is."))
(extend-protocol IEMFValues2ClojureValues
UniqueEList
(emf2clj-internal [this] (into (os/ordered-set) (seq this)))
EMap
(emf2clj-internal [this] (into (om/ordered-map) (seq this)))
EList
(emf2clj-internal [this] (into (vector) this))
Object
(emf2clj-internal [this] this)
nil
(emf2clj-internal [_] nil))
(defn ^:private emf2clj
"Converts an EMF value (e.g., an EList) to an appropriate clojure value."
[val]
(emf2clj-internal val))
(defn eget-raw
"Returns the value of `eo`s structural feature `sf`.
Throws an exception, if there's no EStructuralFeature `sf`.
The value is kept as-is, i.e., not converted to some immutable clojure data
structure as `eget` does. So if you eget-raw an EList, you can mutate it
in-place. That's totally not stylish, but it might be a last resort when
optimizing for performance. You've been warned!"
[^EObject eo sf]
(if-let [sfeat (if (instance? EStructuralFeature sf)
sf
(.getEStructuralFeature (.eClass eo) (name sf)))]
(.eGet eo sfeat)
(u/errorf "No such structural feature %s for %s." sf (print-str eo))))
(defn eget
"Returns the value of `eo`s structural feature `sf`.
The value is converted to some clojure type (see IEMFValues2ClojureValues protocol).
Throws an exception, if there's no EStructuralFeature `sf`."
[^EObject eo sf]
(emf2clj-internal (eget-raw eo sf)))
(defn eset!
"Sets `eo`s structural feature `sf` to `value` and returns `eo`.
Throws an exception, if there's no EStructuralFeature `sf`."
[^EObject eo sf value]
(if-let [sfeat (.getEStructuralFeature (.eClass eo) (name sf))]
(if (.isMany sfeat)
(do
(.eUnset eo sfeat)
(.addAll ^EList (.eGet eo sfeat) value)
eo)
(do
(cond
(and (instance? Long value)
(-> sfeat
.getEType