Skip to content

Commit

Permalink
refactor: applying constraints now is more straightforward
Browse files Browse the repository at this point in the history
  • Loading branch information
krvital committed Oct 4, 2024
1 parent ec91b1c commit 1810613
Show file tree
Hide file tree
Showing 9 changed files with 290 additions and 286 deletions.
288 changes: 149 additions & 139 deletions src/aidbox_sdk/converter.clj
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,43 @@
[clojure.string :as str]
[clojure.walk :as walk]))

;;
;; Topological Sorting of IR Schemas
;;

(defn build-dependency-graph [schemas]
(let [name->map (reduce (fn [acc v] (assoc acc (:url v) v)) schemas)]
(reduce (fn [graph {:keys [url base]}]
(if (and base (contains? name->map base))
(update graph url conj base)
graph))
(zipmap (map :url schemas) (repeat #{}))
schemas)))

(defn topological-sort
"https://en.wikipedia.org/wiki/Topological_sorting"
[graph]
(when (seq graph)
(when-let [depless (keep (fn [[k v]] (when (empty? v) k)) graph)]
(concat depless
(topological-sort
(into {}
(map (fn [[k v]] [k (apply disj v depless)]))
(apply dissoc graph depless)))))))

(defn sort-by-base
"Sorts IR schemas by base class in topological order.
This ensures that base classes are generated before their inheriting classes."
[ir-schemas]
(->> ir-schemas
build-dependency-graph
topological-sort
(map (fn [url] (fhir/find-by-url url ir-schemas)))))

;;
;;
;;

(def primitives #{"dateTime" "xhtml" "Distance" "time" "date" "string" "uuid" "oid" "id" "Dosage" "Duration" "instant" "Count" "decimal" "code" "base64Binary" "unsignedInt" "url" "markdown" "uri" "positiveInt" "canonical" "Age" "Timing"})

(defn url->resource-name
Expand Down Expand Up @@ -263,144 +300,117 @@
;; Constraints
;;

(defn apply-excluded [excluded schema]
(filter (fn [field-schema]
(not (some #(= % (:name field-schema)) excluded)))
schema))

(defn apply-required [required elements]
(->> elements
(map (fn [element]
(if (contains? (set required) (:name element))
(assoc element :required true)
element)))))

(defn apply-choices [choices schema]
(->> choices
(map (fn [[key item]] (set/difference
(set (:choices (first (filter #(= (:name %) (name key)) schema))))
(set (:choices item)))))
(reduce set/union #{})
((fn [choices-to-exclude]
(filter #(not (contains? choices-to-exclude (:name %))) schema)))))

(defn pattern-codeable-concept [name schema]
(->> (str "}")
(str "\tpublic new " (str/join ", " (map #(str "Coding" (str/join (str/split (:code %) #"-"))) (get-in schema [:pattern :coding] []))) "[] Coding { get; } = [new()];\n") #_(str/join ", " (map #(str "Coding" (str/join (str/split (:code %) #"-")) "()") (get-in schema [:pattern :coding] [])))
(str "\nclass " (str/join (map uppercase-first-letter (str/split name #"-"))) " : CodeableConcept\n{\n")
(str (when-let [coding (:coding (:pattern schema))]
(str/join (map (fn [code]
(->> (str "}")
(str (when (contains? code :code) (str "\tpublic new string Code { get; } = \"" (:code code) "\";\n")))
(str (when (contains? code :system) (str "\tpublic new string System { get; } = \"" (:system code) "\";\n")))
(str (when (contains? code :display) (str "\tpublic new string Display { get; } = \"" (:display code) "\";\n")))
(str "\n\nclass Coding" (str/join (str/split (:code code) #"-")) " : Coding\n{\n"))) coding))) "\n")))

(defn create-single-pattern [constraint-name [key schema] elements]
(case (url->resource-name (some #(when (= (name key) (:name %)) (:value %)) elements))
"CodeableConcept" (pattern-codeable-concept (str (uppercase-first-letter (url->resource-name constraint-name)) (uppercase-first-letter (subs (str key) 1))) schema) ""))

(defn apply-patterns [constraint-name patterns schema]
(->> (map (fn [item]
(if-let [pattern (some #(when (= (name (first %)) (:name item)) (last %)) patterns)]
(case (:value item)
"str" (assoc item :value (:pattern pattern) :literal true)
"CodeableConcept" (conj item (hash-map :value (str
(str/join
(map uppercase-first-letter
(str/split (url->resource-name constraint-name) #"-")))
(str/join (map uppercase-first-letter
(str/split (:name item) #"-"))))
:codeable-concept-pattern true))
"Quantity" item item) item)) (:elements schema))
(hash-map :elements) (conj schema (hash-map :patterns (concat (get schema :patterns []) (map (fn [item] (create-single-pattern constraint-name item (:elements schema))) patterns))))))

(defn add-meta [constraint-name elements]
(->> (filter #(not (= (:name %) "meta")) elements)
(concat [{:name "meta"
:required true
:value "Meta"
:profile constraint-name
:type "Meta"
:meta (str " = new() { Profile = [\"" constraint-name "\"] };")}])))

(defn copy-from-constraint [properties new-schema]
(merge new-schema properties))

(defn convert-constraint [constraint parent-schema]
(->> (:elements parent-schema)
(apply-required (:required constraint))
(apply-excluded (:excluded constraint))
(apply-choices (filter #(contains? (last %) :choices)
(:elements constraint)))
(add-meta (:url constraint))
(hash-map :elements)
(conj parent-schema)
(copy-from-constraint {:package (:package constraint)
:derivation (:derivation constraint)})
(apply-patterns (:url constraint)
(filter #(contains? (last %) :pattern)
(:elements constraint)))
((fn [schema] (update schema :deps set/union #{"Meta"})))
((fn [schema] (assoc schema :resource-name (url->resource-name (:url constraint)) )))))

(defn convert-constraints [constraint-schemas base-schemas]
(let [base-schemas (vector->map base-schemas)]
(loop [result {}]
(if (= (count constraint-schemas) (count result))
result
(recur
(reduce (fn [acc constraint-schema]
(cond
(contains? result (:url constraint-schema))
acc

(contains? result (:base constraint-schema))
(assoc acc
(:url constraint-schema)
(convert-constraint constraint-schema
(get result (:base constraint-schema))))
#_(defn apply-choices [choices schema]
(->> choices
(map (fn [[key item]] (set/difference
(set (:choices (first (filter #(= (:name %) (name key)) schema))))
(set (:choices item)))))
(reduce set/union #{})
((fn [choices-to-exclude]
(filter #(not (contains? choices-to-exclude (:name %))) schema)))))

#_(defn pattern-codeable-concept [name schema]
(->> (str "}")
(str "\tpublic new " (str/join ", " (map #(str "Coding" (str/join (str/split (:code %) #"-"))) (get-in schema [:pattern :coding] []))) "[] Coding { get; } = [new()];\n") #_(str/join ", " (map #(str "Coding" (str/join (str/split (:code %) #"-")) "()") (get-in schema [:pattern :coding] [])))
(str "\nclass " (str/join (map uppercase-first-letter (str/split name #"-"))) " : CodeableConcept\n{\n")
(str (when-let [coding (:coding (:pattern schema))]
(str/join (map (fn [code]
(->> (str "}")
(str (when (contains? code :code) (str "\tpublic new string Code { get; } = \"" (:code code) "\";\n")))
(str (when (contains? code :system) (str "\tpublic new string System { get; } = \"" (:system code) "\";\n")))
(str (when (contains? code :display) (str "\tpublic new string Display { get; } = \"" (:display code) "\";\n")))
(str "\n\nclass Coding" (str/join (str/split (:code code) #"-")) " : Coding\n{\n"))) coding))) "\n")))

#_(defn create-single-pattern [constraint-name [key schema] elements]
(case (url->resource-name (some #(when (= (name key) (:name %)) (:value %)) elements))
"CodeableConcept" (pattern-codeable-concept (str (uppercase-first-letter (url->resource-name constraint-name)) (uppercase-first-letter (subs (str key) 1))) schema) ""))

#_(defn apply-patterns [constraint-name patterns schema]
(->> (map (fn [item]
(if-let [pattern (some #(when (= (name (first %)) (:name item))
(last %))
patterns)]
(case (:value item)
"str" (assoc item :value (:pattern pattern) :literal true)
"CodeableConcept" (conj item (hash-map :value (str
(str/join
(map uppercase-first-letter
(str/split (url->resource-name constraint-name) #"-")))
(str/join (map uppercase-first-letter
(str/split (:name item) #"-"))))
:codeable-concept-pattern true))
"Quantity" item item) item)))
(hash-map :elements) (conj schema (hash-map :patterns (concat (get schema :patterns []) (map (fn [item] (create-single-pattern constraint-name item (:elements schema))) patterns))))))

#_(defn copy-from-constraint [properties new-schema]
(merge new-schema properties))

#_(defn convert-constraint [constraint base-schema]
(->> (:elements base-schema)
(apply-required (:required constraint))
(apply-excluded (:excluded constraint))
(apply-choices (filter #(contains? (last %) :choices)
(:elements constraint)))
(add-meta (:url constraint))
(hash-map :elements)
(conj base-schema)
(copy-from-constraint {:package (:package constraint)
:derivation (:derivation constraint)})
(apply-patterns (:url constraint)
(filter #(contains? (last %) :pattern)
(:elements constraint)))
((fn [schema] (update schema :deps set/union #{"Meta"})))
((fn [schema] (assoc schema :resource-name (url->resource-name (:url constraint)))))))


(defn apply-constraint [base-schema constraint]
(-> base-schema
;; apply required
(update :elements
(fn [elements]
(map (fn [element]
(if (contains? (set (:required constraint)) (:name element))
(assoc element :required true)
element))
elements)))

;; apply excluded
;; TODO update choices too
(update :elements
(fn [elements]
(remove (fn [element]
(contains? (set (:excluded constraint)) (:name element)))
elements)))

(contains? base-schemas (:base constraint-schema))
;; add or update meta element
(update :elements
(fn [elements]
(conj (remove #(= (:name %) "meta") elements)
{:name "meta"
:required true
:value "Meta"
:profile (:url constraint)
:type "Meta"
;; TODO remove this when dotnet generator will be using
;; profile field instead
:meta (str " = new() { Profile = [\"" (:url constraint) "\"] };")})))

;; add Meta to deps
(update :deps set/union #{"Meta"})

;; copy constraint common fields
(assoc :resource-name (url->resource-name (:url constraint)))
(assoc :derivation (:derivation constraint))))

(defn apply-constraints [base-schemas constraints]
(let [base-schemas (vector->map base-schemas)]
(->> constraints
sort-by-base
(reduce (fn [acc constraint]
(let [base-schema (or (get base-schemas (:base constraint))
(get acc (:base constraint)))]
(assoc acc
(:url constraint-schema)
(convert-constraint constraint-schema
(get base-schemas (:base constraint-schema))))

:else acc))

result
constraint-schemas))))))

;;
;; Topological Sorting of IR Schemas
;;

(defn- build-dependency-graph [schemas]
(let [name->map (reduce (fn [acc v] (assoc acc (:url v) v)) schemas)]
(reduce (fn [graph {:keys [url base]}]
(if (and base (contains? name->map base))
(update graph url conj base)
graph))
(zipmap (map :url schemas) (repeat #{}))
schemas)))

(defn- topological-sort
"https://en.wikipedia.org/wiki/Topological_sorting"
[graph]
(when (seq graph)
(when-let [depless (keep (fn [[k v]] (when (empty? v) k)) graph)]
(concat depless
(topological-sort
(into {}
(map (fn [[k v]] [k (apply disj v depless)]))
(apply dissoc graph depless)))))))

(defn sort-by-base
"Sorts IR schemas by base class in topological order.
This ensures that base classes are generated before their inheriting classes."
[ir-schemas]
(->> ir-schemas
build-dependency-graph
topological-sort
(map (fn [url] (fhir/find-by-url url ir-schemas)))))
(:url constraint)
(apply-constraint base-schema constraint))))
{})
(vals))))
6 changes: 3 additions & 3 deletions src/aidbox_sdk/core.clj
Original file line number Diff line number Diff line change
Expand Up @@ -53,7 +53,6 @@
:typescript typescript/generator
:java java/generator))


(defn generate! [target-language input options]
(let [output-dir (io/file (:output-dir options))
save-files! #(save-files! output-dir %)
Expand Down Expand Up @@ -82,8 +81,9 @@
resource-ir-schemas (converter/convert resource-schemas)
search-param-ir-schemas (converter/convert-search-params search-param-schemas
fhir-schemas)
constraint-ir-schemas (converter/convert-constraints constraint-schemas
(remove fhir/constraint? ir-schemas))
constraint-ir-schemas (converter/apply-constraints
(filter fhir/specialization? ir-schemas)
constraint-schemas)

generator' (lang->generator target-language)

Expand Down
12 changes: 6 additions & 6 deletions src/aidbox_sdk/generator/dotnet.clj
Original file line number Diff line number Diff line change
Expand Up @@ -280,12 +280,12 @@
(:elements ir-schema))}))})
ir-schemas))

(generate-constraints [_ constraint-ir-schemas]
(mapv (fn [[name' schema]]
{:path (constraint-file-path schema name')
:content (generate-constraint-module
(assoc schema :url name'))})
constraint-ir-schemas))
(generate-constraints [_ constrained-ir-schemas]
(map (fn [ir-schema]
{:path (resource-file-path ir-schema)
:content (generate-constraint-module
(assoc ir-schema :url (:url ir-schema)))})
constrained-ir-schemas))

(generate-sdk-files [_] (generator/prepare-sdk-files :dotnet)))

Expand Down
4 changes: 2 additions & 2 deletions src/aidbox_sdk/generator/helpers.clj
Original file line number Diff line number Diff line change
Expand Up @@ -26,8 +26,8 @@

(defn uppercase-first-letter
"NOTE: Do not confuse with `capitalize` and `->pascal-case` functions.
Capitalize function lowercasing all letters after first.
Pascal case removes all _ and - characters"
`capitalize` function lowercasing all letters after first.
`->pascal-case` removes all _ and - characters"
[s]
(str (str/upper-case (get s 0 "")) (str/join (rest s))))

Expand Down
Loading

0 comments on commit 1810613

Please sign in to comment.