pure-functional-io.clj

;; Pure functional I/O using clojure
;; =================================
;;
;; Defines a grammar of three operations in `defrecord Operation` using the free monad technique
;; 1. read file
;; 2. write file
;; 3. print to standard output
;;
;; Defines I/O operations by combining the Operation grammar in `defrecord IO`
;;
;; Demonstrates two programs `p1` and `p2` which are equivalent programs. I/O operations are substituted in p2 with an expression
;;
;; The `defrecord Either` type is ancillary and necessary for definining a sum type.
;;
;; I/O Operations
;;   read-file :: FilePath -> IO String
;;   write-file :: FilePath -> String -> IO ()
;;   putstr :: String -> IO ()
;; =================================

;; BEGIN definition of sum type (API trimmed)

(defrecord Either [unwrap])

(defn left [a]
  (Either. (fn [l _] (l a))))

(defn right [b]
  (Either. (fn [_ r] (r b))))

(defn fold [l r e]
  ((:unwrap e) l r))

(defn bimap [f g e]
  (fold (comp left f) (comp right g) e))

(defn map-right [f e]
  (bimap identity f e))

;; END definition of sum type

;; BEGIN definition of grammar (three operations) using the free monad technique

; Operation a ~ Either (FilePath, String -> a) (Either (FilePath, String, a) (String, a))
(defrecord Operation [unwrap-operation])

; FilePath -> (String -> a) -> Operation a
(defn read-file-operation [fp f]
  (Operation. (left [fp f])))

; FilePath -> String -> a -> Operation a
(defn write-file-operation [fp c a]
  (Operation. (right (left [fp c a]))))

; String -> a -> Operation a
(defn putstr-operation [c a]
  (Operation. (right (right [c a]))))

; (FilePath -> (String -> a) -> x) -> (FilePath -> String -> a -> x) -> (String -> a -> x) -> Operation a -> x
(defn fold-operation [rf wf pr op]
  (fold (fn [[fp f]] (rf fp f)) #(fold (fn [[fp c a]] (wf fp c a)) (fn [[c a]] (pr c a)) %) (:unwrap-operation op)))

; (a -> b) -> Operation a -> Operation b
(defn map-operation [f op]
  (fold-operation
  (fn [fp fn](read-file-operation fp (comp f fn)))
  (fn [fp c a] (write-file-operation fp c (f a)))
  (fn [c a] (putstr-operation c (f a))) op))

;; END definition of grammar (three operations) using the free monad technique

;; BEGIN definition of I/O operations

; IO a ~ Either a (Operation (IO a))
(defrecord IO [unwrap-io])

; a -> IO a
(defn done [a]
  (IO. (left a)))

; Operation (IO a) -> IO a
(defn more [op]
  (IO. (right op)))

; (a -> x) -> (Operation (IO a) -> x) -> x
(defn fold-io [d m io]
  (fold d m (:unwrap-io io)))

; Operation a -> IO a
(defn lift-operation [op]
  (more (map-operation #(done %) op)))

; FilePath -> IO String
(defn read-file [fp]
  (lift-operation (read-file-operation fp #(identity %))))

; FilePath -> String -> IO ()
(defn write-file [fp, c]
  (lift-operation (write-file-operation fp c nil)))

; String -> IO ()
(defn putstr [c]
  (lift-operation (putstr-operation c nil)))

; (a -> b) -> IO a -> IO b
(defn map-io [f io]
  (fold-io (fn [a] (done (f a))) (fn [op] (more (map-operation #(map-io f %) op))) io))

; (a -> IO b) -> IO a -> IO b
(defn mapcat-io [f io]
  (fold-io f (fn [op] (more (map-operation #(mapcat-io f %) op))) io))

; IO a -> (a -> IO b) -> IO b
(defn catmap-io [io f]
  (mapcat-io f io))

; alias for catmap-io
; IO a -> (a -> IO b) -> IO b
(defn +--> [io f]
  (catmap-io io f))

; IO a -> IO b -> IO b
(defn then [io1 io2]
  (catmap-io io1 (fn [_] io2)))

;; END definition of I/O operations

; CAUTION: unsafe, use once-per-program
; Interpreter for running I/O programs in a main function
; IO a -> a
(defn interpret-io [io]
  (fold-io identity
           #(fold-operation
             (fn [fp f] (let [c (slurp fp)] (interpret-io (f c))))
             (fn [fp c a] (do (spit fp c) (interpret-io a)))
             (fn [c a] (do (println c) (interpret-io a))) %) io))

;;;;

(def p1-io
  (let
    [ file "/tmp/file" ]
    (then (write-file file "abcdef")
    (+--> (read-file file) (fn [x]
    (then (putstr x)
    (then (write-file file "ghijkl")
    (+--> (read-file file) (fn [y]
    (putstr [x y]))))))))))

(def p2-io
  (let
    [ file "/tmp/file"
      expr (read-file file)]
    (then (write-file file "abcdef")
    (+--> expr (fn [x]
    (then (putstr x)
    (then (write-file file "ghijkl")
    (+--> expr (fn [y]
    (putstr [x y]))))))))))

(defn p1 [] (interpret-io p1-io))

(defn p2 [] (interpret-io p2-io))