Merge pull request #835 from samply/remove-single-scope

Fix CQL Function Argument Hiding

.github/workflows/build.yml

@@ -447,6 +447,9 @@ jobs:
     - name: Evaluate CQL Query 34 - Subject List
       run: .github/scripts/evaluate-measure-subject-list.sh modules/operation-measure-evaluate-measure/test/blaze/fhir/operation/evaluate_measure/q37-overlaps.cql 24
 
+    - name: Evaluate CQL Query 46
+      run: .github/scripts/evaluate-measure.sh modules/operation-measure-evaluate-measure/test/blaze/fhir/operation/evaluate_measure//q46-between-date.cql 19
+
     - name: Forwarded Header HTTPS
       run: .github/scripts/forwarded-header.sh https
 
@@ -919,6 +922,9 @@ jobs:
     - name: Evaluate CQL Query 34 - Subject List
       run: .github/scripts/evaluate-measure-subject-list.sh modules/operation-measure-evaluate-measure/test/blaze/fhir/operation/evaluate_measure/q37-overlaps.cql 24
 
+    - name: Evaluate CQL Query 46
+      run: .github/scripts/evaluate-measure.sh modules/operation-measure-evaluate-measure/test/blaze/fhir/operation/evaluate_measure//q46-between-date.cql 19
+
     - name: Forwarded Header HTTPS
       run: .github/scripts/forwarded-header.sh https
 

modules/cql/src/blaze/elm/compiler/macros.clj

@@ -91,7 +91,9 @@
        (reify core/Expression
          (~'-eval [~'_ context# resource# scope#]
            (let [~operands-binding (mapv #(core/-eval % context# resource# scope#) operands#)]
-             ~@body))))))
+             ~@body))
+         (~'-form [~'_]
+           (cons (quote ~name) (map core/-form operands#)))))))
 
 
 (defmacro defaggop

modules/cql/src/blaze/elm/compiler/queries.clj

@@ -19,17 +19,18 @@
 
 
 (defprotocol XformFactory
-  (-create [_ context resource]
+  (-create [_ context resource scope]
     "Creates a xform which filters and/or shapes query sources.")
   (-form [_]))
 
 
 (defrecord WithXformFactory
-  [rhs rhs-operand such-that lhs-operand single-query-scope]
+  [rhs rhs-operand rhs-alias such-that lhs-operand lhs-alias]
   XformFactory
-  (-create [_ context resource]
-    (let [rhs (core/-eval rhs context resource nil)
-          indexer #(core/-eval rhs-operand context resource %)]
+  (-create [_ context resource scope]
+    (let [rhs (core/-eval rhs context resource scope)
+          indexer #(core/-eval rhs-operand context resource
+                               (assoc scope rhs-alias %))]
       (if (some? such-that)
         (let [index (group-by indexer rhs)]
           (filter
@@ -39,12 +40,13 @@
                                                (get index))]
                 (some
                   #(core/-eval such-that context resource
-                               {single-query-scope lhs-entity alias %})
+                               (assoc scope lhs-alias lhs-entity rhs-alias %))
                   rhs-entities)))))
         (let [index (into #{} (map indexer) rhs)]
           (filter
             (fn eval-with-clause [lhs-entity]
-              (some->> (core/-eval lhs-operand context resource lhs-entity)
+              (some->> (core/-eval lhs-operand context resource
+                                   (assoc scope lhs-alias lhs-entity))
                        (contains? index))))))))
   (-form [_]
     (list 'with (core/-form rhs))))
@@ -56,54 +58,58 @@
         (filter #(with-clause context resource %)))))
 
 
-(defrecord WhereXformFactory [expr]
+(defrecord WhereXformFactory [alias expr]
   XformFactory
-  (-create [_ context resource]
-    (filter #(core/-eval expr context resource %)))
+  (-create [_ context resource scope]
+    (filter #(core/-eval expr context resource (assoc scope alias %))))
   (-form [_]
-    `(~'where ~(core/-form expr))))
+    `(~'where ~(symbol alias) ~(core/-form expr))))
 
 
-(defn- where-xform-factory [expr]
-  (->WhereXformFactory expr))
+(defn- where-xform-factory [alias expr]
+  (->WhereXformFactory alias expr))
 
 
-(defrecord ReturnXformFactory [expr]
+(defrecord ReturnXformFactory [alias expr]
   XformFactory
-  (-create [_ context resource]
-    (map #(core/-eval expr context resource %))))
+  (-create [_ context resource scope]
+    (map #(core/-eval expr context resource (assoc scope alias %))))
+  (-form [_]
+    `(~'return ~(symbol alias) ~(core/-form expr))))
 
 
 (defrecord DistinctXformFactory []
   XformFactory
-  (-create [_ _ _]
+  (-create [_ _ _ _]
     (distinct))
   (-form [_]
     'distinct))
 
 
 (defrecord ComposedDistinctXformFactory [xform-factory]
   XformFactory
-  (-create [_ context resource]
+  (-create [_ context resource scope]
     (comp
-      (-create xform-factory context resource)
-      (distinct))))
+      (-create xform-factory context resource scope)
+      (distinct)))
+  (-form [_]
+    `(~'distinct ~(-form xform-factory))))
 
 
-(defn- return-xform-factory [expr distinct]
+(defn- return-xform-factory [alias expr distinct]
   (if (some? expr)
     (if distinct
-      (-> (->ReturnXformFactory expr)
+      (-> (->ReturnXformFactory alias expr)
           (->ComposedDistinctXformFactory))
-      (->ReturnXformFactory expr))
+      (->ReturnXformFactory alias expr))
     (when distinct
       (->DistinctXformFactory))))
 
 
 (defrecord ComposedXformFactory [factories]
   XformFactory
-  (-create [_ context resource]
-    (transduce (map #(-create % context resource)) comp factories))
+  (-create [_ context resource scope]
+    (transduce (map #(-create % context resource scope)) comp factories))
   (-form [_]
     `(~'comp ~@(map -form factories))))
 
@@ -133,7 +139,7 @@
   core/Expression
   (-eval [_ context resource scope]
     (coll/eduction
-      (-create xform-factory context resource)
+      (-create xform-factory context resource scope)
       (core/-eval source context resource scope)))
   (-form [_]
     `(~'eduction-query ~(-form xform-factory) ~(core/-form source))))
@@ -148,7 +154,7 @@
   (-eval [_ context resource scope]
     (into
       []
-      (-create xform-factory context resource)
+      (-create xform-factory context resource scope)
       (core/-eval source context resource scope)))
   (-form [_]
     `(~'vector-query ~(-form xform-factory) ~(core/-form source))))
@@ -215,7 +221,7 @@
     ;; TODO: build a comparator of all sort by items
     (->> (into
            []
-           (-create xform-factory context resource)
+           (-create xform-factory context resource scope)
            (core/-eval source context resource scope))
          (sort-by
            (if-let [expr (:expression sort-by-item)]
@@ -278,12 +284,11 @@
     (let [{:keys [expression alias]} (first sources)
           context (dissoc context :optimizations)
           source (core/compile* context expression)
-          context (assoc context :life/single-query-scope alias)
           with-equiv-clauses (filter (comp #{"WithEquiv"} :type) relationships)
-          with-xform-factories (map #(compile-with-equiv-clause context %) with-equiv-clauses)
-          where-xform-factory (some->> where (core/compile* context) (where-xform-factory))
+          with-xform-factories (map #(compile-with-equiv-clause context alias %) with-equiv-clauses)
+          where-xform-factory (some->> where (core/compile* context) (where-xform-factory alias))
           distinct (if (contains? optimizations :non-distinct) false distinct)
-          return-xform-factory (return-xform-factory (some->> return (core/compile* context)) distinct)
+          return-xform-factory (return-xform-factory alias (some->> return (core/compile* context)) distinct)
           xform-factory (xform-factory with-xform-factories where-xform-factory return-xform-factory)
           sort-by-items (mapv #(compile-sort-by-item context %) sort-by-items)]
       (if (empty? sort-by-items)
@@ -305,23 +310,14 @@
 (defrecord AliasRefExpression [key]
   core/Expression
   (-eval [_ _ _ scopes]
-    (get scopes key)))
-
-
-(defrecord SingleScopeAliasRefExpression []
-  core/Expression
-  (-eval [_ _ _ scope]
-    scope))
-
-
-(def single-scope-alias-ref-expression (->SingleScopeAliasRefExpression))
+    (get scopes key))
+  (-form [_]
+    `(~'alias-ref ~(symbol key))))
 
 
 (defmethod core/compile* :elm.compiler.type/alias-ref
-  [{:life/keys [single-query-scope]} {:keys [name]}]
-  (if (= single-query-scope name)
-    single-scope-alias-ref-expression
-    (->AliasRefExpression name)))
+  [_ {:keys [name]}]
+  (->AliasRefExpression name))
 
 
 ;; 10.7 IdentifierRef
@@ -358,26 +354,20 @@
   the semi-join here.
 
   Returns an XformFactory."
-  {:arglists '([context with-equiv-clause])}
-  [context {:keys [alias] rhs :expression equiv-operands :equivOperand
-            such-that :suchThat}]
-  (if-let [single-query-scope (:life/single-query-scope context)]
-    (if-let [rhs-operand (find-operand-with-alias equiv-operands alias)]
-      (if-let [lhs-operand (find-operand-with-alias equiv-operands
-                                                    single-query-scope)]
-        (let [rhs (core/compile* context rhs)
-              rhs-operand (core/compile* (assoc context :life/single-query-scope alias)
-                                         rhs-operand)
-              lhs-operand (core/compile* context lhs-operand)
-              such-that (some->> such-that
-                                 (core/compile* (dissoc context :life/single-query-scope)))]
-          (->WithXformFactory rhs rhs-operand such-that lhs-operand
-                              single-query-scope))
-        (throw-anom missing-lhs-operand-anom))
-      (throw-anom (missing-rhs-operand-anom alias)))
-    (throw-anom
-      (ba/incorrect
-        (format "Unsupported call without single query scope.")))))
+  {:arglists '([context lhs-alias with-equiv-clause])}
+  [context
+   lhs-alias
+   {rhs-alias :alias rhs :expression equiv-operands :equivOperand
+    such-that :suchThat}]
+  (if-let [rhs-operand (find-operand-with-alias equiv-operands rhs-alias)]
+    (if-let [lhs-operand (find-operand-with-alias equiv-operands lhs-alias)]
+      (let [rhs (core/compile* context rhs)
+            rhs-operand (core/compile* context rhs-operand)
+            lhs-operand (core/compile* context lhs-operand)
+            such-that (some->> such-that (core/compile* context))]
+        (->WithXformFactory rhs rhs-operand rhs-alias such-that lhs-operand lhs-alias))
+      (throw-anom missing-lhs-operand-anom))
+    (throw-anom (missing-rhs-operand-anom rhs-alias))))
 
 
 ;; TODO 10.15. Without

modules/cql/src/blaze/elm/compiler/structured_values.clj

@@ -121,13 +121,11 @@
 
 
 (defmethod core/compile* :elm.compiler.type/property
-  [{:life/keys [single-query-scope] :as context} {:keys [source scope path]}]
+  [context {:keys [source scope path]}]
   (let [key (path->key path)]
     (cond
       source
       (->SourcePropertyExpression (core/compile* context source) key)
 
       scope
-      (if (= single-query-scope scope)
-        (->SingleScopePropertyExpression key)
-        (->ScopePropertyExpression scope key)))))
+      (->ScopePropertyExpression scope key))))

modules/cql/test/blaze/elm/compiler/queries_test.clj

@@ -100,13 +100,19 @@
              (code/to-code "foo" nil "c")]))))
 
     (testing "Return non-distinct"
-      (are [query res] (= res (core/-eval (c/compile {} query) {} nil nil))
-        {:type "Query"
-         :source
-         [{:alias "S"
-           :expression #elm/list [#elm/integer "1" #elm/integer "1"]}]
-         :return {:distinct false :expression {:type "AliasRef" :name "S"}}}
-        [1 1]))
+      (let [elm {:type "Query"
+                 :source
+                 [{:alias "S"
+                   :expression #elm/list [#elm/integer "1" #elm/integer "1"]}]
+                 :return {:distinct false :expression {:type "AliasRef" :name "S"}}}
+            expr (c/compile {} elm)]
+
+        (testing "eval"
+          (is (= [1 1] (core/-eval expr {} nil nil))))
+
+        (testing "form"
+          (is (= '(vector-query (return S (alias-ref S)) [1 1])
+                 (core/-form expr))))))
 
     (testing "with query hint optimize first"
       (let [elm {:type "Query"
@@ -146,6 +152,7 @@
                    [{:alias "P"
                      :expression retrieve}]}
               expr (c/compile {:node node :eval-context "Unfiltered"} elm)]
+
           (testing "eval"
             (given (core/-eval expr {:db db} nil nil)
               [0 fhir-spec/fhir-type] := :fhir/Patient
@@ -165,7 +172,7 @@
 
           (testing "form"
             (is (= '(vector-query
-                      (comp (where (equal (:gender default) 2)) distinct)
+                      (comp (where P (equal (:gender P) 2)) distinct)
                       (retrieve "Patient"))
                    (core/-form expr)))))
 
@@ -227,9 +234,12 @@
 
 ;; 10.3. AliasRef
 (deftest compile-alias-ref-test
-  (are [elm res] (= res (core/-eval (c/compile {} elm) {} nil {"foo" ::result}))
-    {:type "AliasRef" :name "foo"}
-    ::result))
+  (let [expr (c/compile {} {:type "AliasRef" :name "foo"})]
+    (testing "eval"
+      (is (= ::result (core/-eval expr {} nil {"foo" ::result}))))
+
+    (testing "form"
+      (is (= '(alias-ref foo) (core/-form expr))))))
 
 
 ;; 10.7 IdentifierRef
@@ -274,13 +284,19 @@
                    :life/scopes #{"O1"}
                    :life/source-type "{http://hl7.org/fhir}Observation"}]}
             compile-context
-            {:node node :life/single-query-scope "O0" :eval-context "Unfiltered"}
-            xform-factory (queries/compile-with-equiv-clause compile-context elm)
+            {:node node :eval-context "Unfiltered"}
+            xform-factory (queries/compile-with-equiv-clause compile-context "O0" elm)
             eval-context {:db (d/db node)}
-            xform (queries/-create xform-factory eval-context nil)
+            xform (queries/-create xform-factory eval-context nil nil)
             lhs-entity {:fhir/type :fhir/Observation
                         :subject #fhir/Reference{:reference "Patient/0"}}]
-        (is (= [lhs-entity] (into [] xform [lhs-entity]))))))
+
+        (testing "filtering"
+          (is (= [lhs-entity] (into [] xform [lhs-entity]))))
+
+        (testing "form"
+          (is (= '(with (retrieve "Observation"))
+                 (queries/-form xform-factory)))))))
 
   (testing "Equiv With with one Patient and one Observation comparing the patient with the operation subject."
     (with-system-data [{:blaze.db/keys [node]} mem-node-system]
@@ -303,9 +319,9 @@
                    :life/scopes #{"O"}
                    :life/source-type "{http://hl7.org/fhir}Observation"}]}
             compile-context
-            {:node node :life/single-query-scope "P" :eval-context "Unfiltered"}
-            xform-factory (queries/compile-with-equiv-clause compile-context elm)
+            {:node node :eval-context "Unfiltered"}
+            xform-factory (queries/compile-with-equiv-clause compile-context "P" elm)
             eval-context {:db (d/db node)}
-            xform (queries/-create xform-factory eval-context nil)
+            xform (queries/-create xform-factory eval-context nil nil)
             lhs-entity #fhir/Reference{:reference "Patient/0"}]
         (is (= [lhs-entity] (into [] xform [lhs-entity])))))))

modules/cql/test/blaze/elm/compiler/string_operators_test.clj

@@ -69,7 +69,13 @@
     [#elm/string "a" #elm/string "b"] "ab"
 
     [#elm/string "a" {:type "Null"}] nil
-    [{:type "Null"}] nil))
+    [{:type "Null"}] nil)
+
+  (testing "form"
+    (are [args form] (= form (core/-form (c/compile {} {:type "Concatenate" :operand args})))
+      [#elm/string "a"] '(concatenate "a")
+      [#elm/string "a" #elm/string "b"] '(concatenate "a" "b")
+      [#elm/string "a" {:type "Null"}] '(concatenate "a" nil))))
 
 
 ;; 17.3. EndsWith