From 10081333a9e116d087825ec7be31099ab4bbe97d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 30 Apr 2015 17:35:31 -0400 Subject: - Implemented pattern-matching for records. - Added some code to allow variant creation with existential types. (NOTE: Check if it's actually valid) - Modify var cleanup to leave the var as-is if it has been deleted. (NOTE: Need to find out why a variable is left prior to being deleted) --- src/lux/analyser/case.clj | 61 +++++++++++++++++++++++++++++------------------ src/lux/analyser/lux.clj | 28 +++++++++++++--------- src/lux/compiler/case.clj | 25 ++++++++++++++++++- src/lux/type.clj | 41 ++++++++++++++++++++++++------- 4 files changed, 111 insertions(+), 44 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 0c459f0de..8fa2bbaff 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -72,22 +72,31 @@ [_] (fail "[Analyser Error] Tuple requires tuple-type.")) - [["lux;Record" ?fields]] - (&type/with-vars (&/|length ?fields) - (fn [=vars] - (|do [_ (&type/check value-type (&/V "lux;RecordT" (&/zip2 (&/|keys ?fields) =vars))) - [=tests =kont] (&/fold (fn [kont* vm] - (|let [[v [k m]] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (matchv ::M/objects [=kont] - [["Expression" [?val ?type]]] - (|do [=type (&type/clean v ?type)] - (return (&/T (&/|put k =test =tests) - (&/V "Expression" (&/T ?val =type))))))))) - (|do [=kont kont] - (return (&/T (&/|table) =kont))) - (&/|reverse (&/zip2 =vars ?fields)))] - (return (&/T (&/V "RecordTestAC" =tests) =kont))))) + [["lux;Record" ?slots]] + (|do [value-type* (resolve-type value-type)] + (matchv ::M/objects [value-type*] + [["lux;RecordT" ?slot-types]] + (if (not (= (&/|length ?slot-types) (&/|length ?slots))) + (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* slot] + (|let [[sn sv] slot] + (matchv ::M/objects [sn] + [["lux;Meta" [_ ["lux;Tag" ?ident]]]] + (|do [=tag (&&/resolved-ident ?ident)] + (if-let [=slot-type (&/|get =tag ?slot-types)] + (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] + (return (&/T (&/|put =tag =test =tests) =kont))) + (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag)))) + + [_] + (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) + (|do [=kont kont] + (return (&/T (&/|table) =kont))) + (&/|reverse ?slots))] + (return (&/T (&/V "RecordTestAC" =tests) =kont)))) + + [_] + (fail "[Analyser Error] Record requires record-type."))) [["lux;Tag" ?ident]] (|do [=tag (&&/resolved-ident ?ident) @@ -172,21 +181,27 @@ [["DefaultTotal" total?] ["RecordTestAC" ?tests]] (|do [structs (&/map% (fn [t] (|let [[slot value] t] - (|do [struct (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] - (return (&/T slot struct))))) - (sort compare-kv ?tests))] + (|do [struct* (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] + (return (&/T slot struct*))))) + (->> ?tests + &/->seq + (sort compare-kv) + &/->list))] (return (&/V "RecordTotal" (&/T total? structs)))) [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] (if (= (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map% (fn [lr] - (|let [[[lslot struct] [rslot value]] lr] + (|let [[[lslot sub-struct] [rslot value]] lr] (if (= lslot rslot) - (|do [struct (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] - (return (&/T lslot struct))) + (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] + (return (&/T lslot sub-struct*))) (fail "[Pattern-matching error] Record slots mismatch.")))) (&/zip2 ?values - (sort compare-kv ?tests)))] + (->> ?tests + &/->seq + (sort compare-kv) + &/->list)))] (return (&/V "RecordTotal" (&/T total? structs)))) (fail "[Pattern-matching error] Inconsistent record-size.")) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 87db5a125..b9a3ffbf2 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -53,20 +53,26 @@ [_] (&type/actual-type exo-type)) - ?tag (&&/resolved-ident ident) ;; :let [_ (prn 'analyse-variant/exo-type* (&type/show-type exo-type*))] ] (matchv ::M/objects [exo-type*] [["lux;VariantT" ?cases]] - (if-let [vtype (&/|get ?tag ?cases)] - (|do [;; :let [_ (prn 'VARIANT_BODY ?tag (&/show-ast ?value) (&type/show-type vtype))] - =value (&&/analyse-1 analyse vtype ?value) - ;; :let [_ (prn 'GOT_VALUE =value)] - ] - (return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag =value)) - exo-type))))) - (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*)))) - + (|do [?tag (&&/resolved-ident ident)] + (if-let [vtype (&/|get ?tag ?cases)] + (|do [;; :let [_ (prn 'VARIANT_BODY ?tag (&/show-ast ?value) (&type/show-type vtype))] + =value (&&/analyse-1 analyse vtype ?value) + ;; :let [_ (prn 'GOT_VALUE =value)] + ] + (return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag =value)) + exo-type))))) + (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + + [["lux;AllT" _]] + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-variant analyse exo-type** ident ?value)))) + [_] (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) @@ -291,7 +297,7 @@ [_] (fail (str "[Analyser Error] Functions require function types: " ;; (str (aget ?self 0) ";" (aget ?self 1)) - ;; (str (aget ?arg 0) ";" (aget ?arg 1)) + ;; (str( aget ?arg 0) ";" (aget ?arg 1)) ;; (&/show-ast ?body) (&type/show-type exo-type))))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 2f051903b..4e33bd7b1 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -18,7 +18,8 @@ ;; [Utils] (let [+tag-sig+ (&host/->type-signature "java.lang.String") +oclass+ (&host/->class "java.lang.Object") - +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z")] + +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z") + compare-kv #(compare (aget %1 0) (aget %2 0))] (defn ^:private compile-match [writer ?match $target $else] ;; (prn 'compile-match (aget ?match 0) $target $else) (matchv ::M/objects [?match] @@ -95,6 +96,28 @@ (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) + + [["RecordTestAC" ?slots]] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (-> (doto (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)) + (.visitInsn Opcodes/AALOAD) + (compile-match test $next $sub-else) + (.visitLabel $sub-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $next)) + (->> (|let [[idx [_ test]] idx+member + $next (new Label) + $sub-else (new Label)]) + (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?slots)) + (->> ?slots + &/->seq + (sort compare-kv) + &/->list)))]))) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target)) [["VariantTestAC" [?tag ?test]]] (doto writer diff --git a/src/lux/type.clj b/src/lux/type.clj index b1b77d5ab..e5c96d7bd 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -235,7 +235,8 @@ (matchv ::M/objects [type] [["lux;VarT" ?id]] (if (= ?tid ?id) - (deref ?id) + (&/try-all% (&/|list (deref ?id) + (return type))) (return type)) [["lux;LambdaT" [?arg ?return]]] @@ -573,16 +574,32 @@ ;; (|do [_ (check* fixpoints F1 F2) ;; _ (check* fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) - - [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - (|do [[fixpoints _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - [fixpoints _] (check* fixpoints A1 A2)] + [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] + (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + _ (check* fixpoints A1 A2)] (return (&/T fixpoints nil))) - + + ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + ;; [fixpoints** _] (check* fixpoints* A1 A2)] + ;; (return (&/T fixpoints** nil))) + [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + + ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + ;; [fixpoints** _] (check* fixpoints* A1 A2)] + ;; (return (&/T fixpoints** nil))) [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - (|do [[fixpoints _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - [fixpoints _] (check* fixpoints A1 A2)] - (return (&/T fixpoints nil))) + (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) [["lux;AppT" [F A]] _] (let [fp-pair (&/T expected actual) @@ -734,6 +751,12 @@ (|do [type* (apply-type ?all ?param)] (actual-type type*)) + ;; [["lux;AllT" [?env ?self ?arg ?body]]] + ;; (with-var + ;; (fn [$var] + ;; (|do [type* (apply-type type $var)] + ;; (actual-type type*)))) + [_] (return type) )) -- cgit v1.2.3