Skip to content
This repository has been archived by the owner on Jan 2, 2018. It is now read-only.

Commit

Permalink
Reviewed some conduit types
Browse files Browse the repository at this point in the history
  • Loading branch information
@frenchy64
frenchy64 committed Sep 13, 2012
1 parent 1e4913b commit 5fe9fa1
Show file tree
Hide file tree
Showing 3 changed files with 73 additions and 46 deletions.
46 changes: 32 additions & 14 deletions src/typed/core.clj
View file
Expand Up @@ -215,6 +215,11 @@
(defmacro ann-form [form ty]
`(ann-form* ~form '~ty))

(defn unsafe-ann-form* [form ty]
form)

(defmacro unsafe-ann-form [form ty]
`(unsafe-ann-form* ~form '~ty))

(defn tc-ignore-forms* [r]
r)
Expand Down Expand Up @@ -2455,7 +2460,7 @@
%)
[svar scls]))]
(->App (->Name s) (mapv parse-type args))
(throw (Exception. (str "Cannot parse list: " syn))))))))
(throw (Exception. (error-msg "Cannot parse list: " syn))))))))

(defmethod parse-type Cons [l] (parse-type-list l))
(defmethod parse-type IPersistentList [l] (parse-type-list l))
Expand Down Expand Up @@ -3581,7 +3586,8 @@
(NotTypeFilter? t))
(cset-meet (cs-gen V X Y (:type s) (:type t))
(cs-gen V X Y (:type t) (:type s)))
:else (throw (IllegalArgumentException. "Need two filters of same type"))))
:else (throw (IllegalArgumentException. (error-msg "Need two filters of same type "
(unparse-filter s) " " (unparse-filter t))))))

;must be *latent* filter sets
(defn cs-gen-filter-set [V X Y s t]
Expand Down Expand Up @@ -5413,6 +5419,11 @@
[(I (APersistentSet x) Sorted) Any Any * -> (I (IPersistentSet x) Sorted)]
[(IPersistentSet x) Any Any * -> (IPersistentSet x)])))

(ann clojure.core/assoc
(All [b c d]
(Fn [(IPersistentMap b c) b c -> (IPersistentMap b c)]
[(IPersistentVector d) AnyInteger d -> (IPersistentVector d)])))

(comment
(aget my-array 0 1 2)
(aget (aget my-array 0) 1 2)
Expand Down Expand Up @@ -6321,10 +6332,9 @@
ftypes))]
(if success-ret-type
success-ret-type
(throw (Exception. (str (when *current-env*
(str (:line *current-env*) ":"))
"funapp: Arguments did not match function: "
(mapv unparse-type arg-types))))))
(throw (Exception. (error-msg "funapp: Arguments did not match function: "
(unparse-type fexpr-type)
(mapv unparse-type arg-types))))))

;ordinary polymorphic function without dotted rest
(and (Poly? fexpr-type)
Expand Down Expand Up @@ -6763,6 +6773,13 @@

(declare unwrap-poly rewrap-poly)

;unsafe form annotation
(defmethod invoke-special #'unsafe-ann-form*
[{[frm {tsyn :val}] :args :as expr} & [expected]]
(let [parsed-ty (parse-type tsyn)]
(assoc expr
expr-type (ret parsed-ty))))

;form annotation
(defmethod invoke-special #'ann-form*
[{[frm {tsyn :val}] :args :as expr} & [expected]]
Expand Down Expand Up @@ -7365,12 +7382,13 @@
(defn FnResult->Function [{:keys [args kws rest drest body] :as fres}]
{:pre [(FnResult? fres)]
:post [(Function? %)]}
(assert (not (or kws rest drest)))
(let [arg-names (concat (map first args)
(when rest
(first rest))
(when drest
(first drest))) ;TODO kws
(assert (not kws))
(let [arg-names (doall
(concat (map first args)
(when rest
[(first rest)])
(when drest
[(first drest)]))) ;TODO kws
]
(->Function
(map second args)
Expand Down Expand Up @@ -7915,8 +7933,8 @@
args)
rest-arg (when rest
(last args))
cargs (mapv check args (concat dom (when rest-arg
[(RClass-of Seqable [rest])])))
cargs (mapv check args (map ret (concat dom (when rest-arg
[(RClass-of Seqable [rest])]))))
_ (assert (and (= (count fixed-args) (count dom))
(= (boolean rest) (boolean rest-arg)))
(error-msg "Wrong number of arguments to recur"))]
Expand Down
48 changes: 27 additions & 21 deletions test/typed/test/conduit.clj
View file
Expand Up @@ -7,20 +7,16 @@

(def-alias Part (IPersistentMap Any Any))

(def-alias ContRes
(def-alias Result
(All [x]
(U nil ;stream is closed
'[] ;abort/skip
'[x];consume/continue
)))

(def-alias ContGen
(All [x y]
[(ContRes x) -> (ContRes y)]))

(def-alias Cont
(All [x]
[(U nil (ContGen x)) -> (ContRes x)]))
[(U nil [(Result x) -> (Result x)]) -> (Result x)]))

(declare-names ==>)

Expand Down Expand Up @@ -79,7 +75,7 @@
"execute a stream processor function"
[f]
(let [[new-f c] (f nil)
y (c identity)]
y (c (inst identity (Result x)))]
(cond
(nil? new-f) (list)
(empty? y) (recur new-f)
Expand Down Expand Up @@ -109,32 +105,31 @@
(ann nth-fn
(All [x y z]
(Fn ['0 (U nil (==> x z)) -> (==> '[x y] '[z y])]
['1 (U nil (==> x z)) -> (==> '[x y] '[x z])])))
['1 (U nil (==> y z)) -> (==> '[x y] '[x z])])))
(defn nth-fn [n f]
(fn curr-fn [xs]
(let [abort-c (ann-form abort-c
(Fn [(U nil (ContGen '[x y])) -> (ContRes '[z y])]
[(U nil (ContGen '[x y])) -> (ContRes '[x z])]))]
(let [abort-c (ann-form (inst abort-c Any)
(Fn [(U nil [(Result '[x y]) -> (Result '[z y])]) -> (Result '[z y])]
[(U nil [(Result '[x y]) -> (Result '[x z])]) -> (Result '[x z])]))]
(cond
(<= (count xs) n) [curr-fn abort-c]
;added - Ambrose
(nil? f) [nil abort-c]
(nil? f) [nil abort-c] ;added - Ambrose
:else
(let [[new-f new-c] (f (nth xs n))
_ (tc-pr-env "last new-f")
next-c (->
(fn [c]
(if (nil? c)
(new-c nil)
(let [y (new-c identity)]
(let [y (new-c (inst identity (Result z)))]
(if (empty? y)
(c [])
(c [(assoc xs n (first y))])))))
(ann-form (Fn [(U nil (ContGen '[x y])) -> (ContRes '[z y])]
[(U nil (ContGen '[x y])) -> (ContRes '[x z])])))]
(ann-form (Fn [(U nil [(Result '[x y]) -> (Result '[z y])]) -> (Result '[z y])]
[(U nil [(Result '[x y]) -> (Result '[x z])]) -> (Result '[x z])])))]
[(nth-fn n new-f) next-c])))))


(tc-ignore
(defn gather-fn [[fs ys] [f y]]
[(conj fs f) (conj ys y)])

Expand All @@ -154,18 +149,23 @@
(if (some empty? ys)
(c [])
(c [(apply concat ys)])))))]))))
)

(ann select-fn
(All [x y z]
[(IPersistentMap x (==> y z)) -> (==> '[x y] z)]))
[(IPersistentMap x (U nil (==> y z))) -> (==> '[x y] z)]))
(defn select-fn [selection-map]
(fn curr-fn [[v x]]
(if-let [f (or (get selection-map v)
(get selection-map '_))]
(if-let [f (ann-form (or ((inst get (U nil (==> y z))) selection-map v)
((inst get (U nil (==> y z))) selection-map '_))
(U nil (==> y z)))]
(let [[new-f c] (f x)]
[(select-fn (assoc selection-map v new-f)) c])
[((inst select-fn x y z)
((inst assoc x (U nil (==> y z)) Any)
selection-map v new-f)) c])
[curr-fn abort-c])))

(tc-ignore
(defn loop-fn
([f prev-x]
(fn curr-fn [x]
Expand All @@ -190,7 +190,13 @@
(fn [c]
(when c
(c y)))])))))))
)

(ann conduit
'{:a-arr (All [x y]
[[x -> y] -> (I (==> x y)
(IMeta '{:created-by ':a-arr
:args [x -> x]}))])})
(defarrow conduit
[a-arr (ann-form
(fn [f]
Expand Down
25 changes: 14 additions & 11 deletions test/typed/test/monads.clj
View file
Expand Up @@ -25,7 +25,7 @@
[clojure.tools.macro
:refer (with-symbol-macros defsymbolmacro name-with-attributes)]
[typed.core
:refer (tc-ignore check-ns ann def-alias ann-form inst fn> pfn>
:refer (tc-ignore check-ns ann def-alias unsafe-ann-form ann-form inst fn> pfn>
AnyInteger tc-pr-env)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Expand Down Expand Up @@ -398,9 +398,12 @@
[(U nil x) [x -> x] -> (U nil x)])))
m-plus (->
(fn m-plus-maybe [& mvs]
(first (filter #(not (nil? %)) mvs)))
(first ((inst filter (U x nil) x)
(ann-form #(not (nil? %))
[(U x nil) -> Any])
mvs)))
(ann-form (All [x]
[(U nil x) * -> (U nil x)])))
[(U nil x) * -> (U nil x)])))
])

(ann flatten*
Expand All @@ -426,13 +429,13 @@
(ann-form (All [x] [(Seqable x) -> (Seqable (Seqable x))])))
m-bind (->
(fn m-bind-sequence [mv f]
((inst flatten* (Seqable y)) (map f mv)))
(flatten* (map f mv)))
(ann-form (All [x y]
[(Seqable x) [x -> (Seqable (Seqable y))] -> (Seqable (Seqable y))])))
m-zero (list)
m-plus (->
(fn m-plus-sequence [& mvs]
((inst flatten* x) mvs))
(flatten* mvs))
(ann-form (All [x]
[(Seqable x) * -> (Seqable x)])))
])
Expand Down Expand Up @@ -495,8 +498,6 @@
[(State s a) [a -> (State s b)] -> (State s b)])))
])

(tc-ignore

(ann update-state
(All [s]
[[s -> s] -> (State s s)]))
Expand All @@ -513,8 +514,8 @@
"Return a state-monad function that replaces the current state by s and
returns the previous state."
[s]
((inst update-state s) (-> (fn [_] s)
(ann-form [s -> s]))))
(update-state (-> (fn [_] s)
(ann-form [s -> s]))))

(ann fetch-state
(All [s]
Expand All @@ -523,7 +524,7 @@
"Return a state-monad function that returns the current state and does not
modify it."
[]
((inst update-state s) (inst identity s)))
(update-state (inst identity s)))

(ann fetch-val
(All [x y]
Expand All @@ -532,10 +533,12 @@
"Return a state-monad function that assumes the state to be a map and
returns the value corresponding to the given key. The state is not modified."
[key]
(domonad (inst state-m y (IPersistentMap x y) (IPersistentMap x y))
(domonad state-m
[^{:T (IPersistentMap x y)} s (fetch-state)]
(get key s)))

(tc-ignore

(defn update-val
"Return a state-monad function that assumes the state to be a map and
replaces the value associated with the given key by the return value
Expand Down

0 comments on commit 5fe9fa1

Please sign in to comment.