pattern match on monadic result type and value in clojure

monad.clj

(ns whatever
  (:require [clojure.tools.logging :as log]
            [clojure.core.match :as m :refer [match]]
            [clojure.core.match.protocols :as mp]
            [cats.monad.either :as either]
            [clojure.core.async :as async]))
          
(deftype Either [tag]
  mp/ISyntaxTag
  (mp/syntax-tag [_] tag))

(def ok  (Either. ::m/ok))
(def err (Either. ::m/err))

(defn either->tag [e]
  (cond
    (either/right? e) ::m/ok
    (either/left?  e) ::m/err))

(defn tags-match? [pat ocr]
  (= (::m/tag pat) (either->tag ocr)))

(defrecord EitherPattern [pattern])

(defn either-pattern  [pat] (assoc (EitherPattern. pat) ::m/tag (.tag pat)))

(defmethod m/emit-pattern ::m/ok  [pat] (either-pattern pat))
(defmethod m/emit-pattern ::m/err [pat] (either-pattern pat))

(defmethod m/to-source ::m/ok  [pat ocr] `(tags-match? ~pat ~ocr))
(defmethod m/to-source ::m/err [pat ocr] `(tags-match? ~pat ~ocr))


;;; tests

(def right (either/right 5))
(def left  (either/left 5))


;; works as it should, err does not match right
(assert (= false
           (eval (m/to-source (err-pattern err) right))))

;;works as it should, ok does not mmatch left
(assert (= false
           (eval (m/to-source (ok-pattern ok) left))))

;; works as it should
(assert (= 5
           (match [right @right]
             [ok x] x
             [err msg] (str "Err --" msg))))

;;; oops- found a few bugs
;; wrong, the match returns 5 but *should* return "wat"
(assert (= 5
           (match [right @right]
             [err x] x
             [_ _] "wat")))

;; wrong, the match picks the "ok" branch
(assert (= [:error 5]
           (match left
             ok @left
             err {:error-msg @left})))



;;; examples

;;; match only on result type
(let [res (either/right 5)]
  (match [res]
    [ok] @res
    [err] (println "Err --" @res)))

;;; match on result type *and* result value (like how erlang does pattern matching on result tuples)
(let [ch  (async/chan) ;; pretend this channel goes to some other component for further processing or whatever
      res (either/right {:id (util/uuid) :status "HANDLING"})]
  (match [res @res]
    [ok  {:id i :status status}] (do (log/info status) (async/put! ch i))
    [err msg] (log/warn "Error! -- " (str msg))))