free monad.fs

open System
open System.Collections.Generic

let inline ( ^ ) f x = f x


type Terminal<'next> =
    | WriteLine of string * (unit -> 'next)
    | ReadLine of unit    * (string -> 'next) 


module Terminal =
    let rec map f = function
        | WriteLine (arg, next) -> WriteLine(arg, next >> f)
        | ReadLine (arg, next) -> ReadLine(arg, next >> f)



type Cache<'next> =
    | Set of string * Object * (unit -> 'next)
    | Get of string * (Object option -> 'next)
    
    
module Cache =
    let rec map f = function
        | Set (arg, arg1, next) -> Set(arg, arg1, next >> f)
        | Get (arg, next) -> Get(arg, next >> f)
        

type IO<'next> =
    | Pure of 'next
    | Terminal of Terminal<IO<'next>>
    | Cache of Cache<IO<'next>>
    

module IO =
    
    let rec map f = function
        | Pure x -> Pure (f x)
        | Terminal t -> t |> Terminal.map (map f) |> Terminal
        | Cache c -> c |> Cache.map (map f) |> Cache
    
    
    let rec bind f = function
        | Pure x -> f x
        | Terminal exe -> exe |> Terminal.map (bind f) |> Terminal
        | Cache c -> c |> Cache.map (bind f) |> Cache
        


type IOBuilder() =
    member this.Return(x) = Pure x
    member this.Bind(x, f) = IO.bind f x
    member this.Zero() = Pure ()
    
let io = IOBuilder()



let writeLine str = Terminal ^ WriteLine(str, Pure)
let readLine () = Terminal ^ ReadLine((), Pure)

let set key value = Cache ^ Set (key, value, Pure)
let get<'a> key =
    Cache ^ Get (key, Pure)
    |> IO.map ^ Option.bind ^ tryUnbox<'a>

        
let cache = Dictionary() 
let rec interpret io =
    let rec terminal inst = async {
        match inst with
        | WriteLine (arg, next) ->
            printfn "%s" arg
            return! interpret ^ next ()
            
        | ReadLine (arg, next) ->
            return! interpret ^ next "Line from console"
    }
    
    let rec memoryCache inst = async {
        match inst with
        | Get(key, next) ->
            match cache.TryGetValue(key) with
            | true, item -> return! interpret ^ next ^ Some item
            | false, item -> return! interpret ^ next None
        
        | Set(key, value, next) ->
            cache.[key] <- value 
            return! interpret ^ next () 
    }
        
    async {
        match io with
        | Pure x -> return x
        | Terminal t -> return! terminal t
        | Cache c -> return! memoryCache c
    }



let app = io {
    do! writeLine "enter name: "
    let! name = readLine ()
    do! writeLine $"Read: {name}!"
    do! set "last-read-time" DateTime.Now
    let! lastRead = get<DateTime> "last-read-time"
    do! writeLine $"%A{lastRead}"
}    
    

let run = interpret app |> Async.RunSynchronously