Clojure C4 Model #hack

alpha.clj

(ns c4.alpha
  "A library for [C4 model](c4model.com)")

(declare rel)

(defrecord Shape [label description sprite tags link])

(def ^:dynamic *boundaries* (list))

(def ^:private hierarchy
  (-> (make-hierarchy)
      (derive :c4/container :c4/shape)
      (derive :c4/component :c4/shape)
      (derive :c4/system :c4/shape)
      (derive :c4/person :c4/shape)
      (derive :c4/queue :c4/shape)
      (derive :c4/db :c4/shape)
      (derive :c4/containerDb :c4/db)
      (derive :c4/containerQueue :c4/queue)
      (derive :c4/containerDb :c4/db)
      (derive :c4/containerQueue :c4/queue)))

(defn boundary? [{:keys [tags]}]
  (some #(isa? hierarchy % :c4/boundary) tags))

(defmacro with-boundary [v & body]
  `(let [v# ~v]
     (when-not (boundary? v#)
       (throw (ex-info "Invalid boundary" {:value v#})))
     (binding [*boundaries* (conj *boundaries* v#)]
       ~@body)))

(defn boundaries [shape]
  (:c4/boundaries (meta shape)))

(defn create-shape
  [tag parents]
  (doseq [parent parents]
    (alter-var-root #'hierarchy derive tag parent))
  (fn [label & desc+opts]
    (let [[desc opts] (if (string? (first desc+opts))
                        [(first desc+opts) (next desc+opts)]
                        [nil desc+opts])]
      (-> (apply hash-map
                 :label label
                 :description desc
                 opts)
          (update :tags #(into #{tag} %))
          (map->Shape)
          (with-meta {:c4/boundaries *boundaries*})))))

(def enterprise-boundary (create-shape ::EnterpriseBoundary #{:c4/boundary}))
(def system-boundary     (create-shape ::SystemBoundary     #{:c4/boundary}))
(def container-boundary  (create-shape ::ContainerBoundary  #{:c4/boundary}))
(def person              (create-shape ::Person             #{:c4/person}))
(def person-ext          (create-shape ::PersonExt          #{:c4/person}))
(def system              (create-shape ::System             #{:c4/system}))
(def system-db           (create-shape ::SystemDb           #{:c4/db}))
(def system-queue        (create-shape ::SystemQueue        #{:c4/queue}))
(def system-ext          (create-shape ::SystemExt          #{:c4/system}))
(def system-ext-db       (create-shape ::SystemExtDb        #{:c4/db}))
(def system-ext-queue    (create-shape ::SystemExtQueue     #{:c4/queue}))
(def container           (create-shape ::Container          #{:c4/container}))
(def container-db        (create-shape ::ContainerDb        #{:c4/db}))
(def container-queue     (create-shape ::ContainerQueue     #{:c4/queue}))
(def container-ext       (create-shape ::ContainerExt       #{:c4/container}))
(def container-ext-db    (create-shape ::ContainerExtDb     #{:c4/db}))
(def container-ext-queue (create-shape ::ContainerExtQueue  #{:c4/queue}))
(def component           (create-shape ::Component          #{:c4/component}))
(def component-db        (create-shape ::ComponentDb        #{:c4/db}))
(def component-queue     (create-shape ::ComponentQueue     #{:c4/queue}))
(def component-ext       (create-shape ::ComponentExt       #{:c4/component}))
(def component-ext-db    (create-shape ::ComponentExtDb     #{:c4/db}))
(def component-ext-queue (create-shape ::ComponentExtQueue  #{:c4/queue}))
(def deployment-node     (create-shape ::DeploymentNode     #{:c4/node}))
(def node                (create-shape ::Node               #{:c4/node}))
(def node-l              (create-shape ::NodeL              #{:c4/node}))
(def node-r              (create-shape ::NodeR              #{:c4/node}))
(def rel                 (create-shape ::Rel                #{:c4/rel}))
(def rel-l               (create-shape ::RelL               #{:c4/rel}))
(def rel-d               (create-shape ::RelD               #{:c4/rel}))
(def rel-u               (create-shape ::RelU               #{:c4/rel}))
(def rel-r               (create-shape ::RelR               #{:c4/rel}))
(def birel               (create-shape ::BiRel              #{:c4/rel}))

;; (comment
;;   (with-boundary (system-boundary "BankBoundary0")
;;     (def customer-a (person "Banking Customer A" "A customer of the bank, with personal bank accounts."))
;;     (def customer-b (person "Banking CUstomer B"))
;;     (def system-aa (system "Internet Banking System" "..."))
;;     (def system-a (system "Banking System A"))
;;     (def sys-b (system "Banking System B"))
;;     (def sdb (system-db-ext "Mainframe Banking System"))
;;     (def system-c (system-ext "E-mail System"))
;;     (def system-d (system-db "Banking System D Database"))
;;     (def b2 (with-boundary "BankBoundary"
;;               (def system-f (system-queue "Banking System F Queue"))
;;               (def system-g (system-queue-ext "Banking System G Queue")))))
;;     )