Skip to content

Instantly share code, notes, and snippets.

@OnurGumus
Last active September 15, 2024 01:18
Show Gist options
  • Save OnurGumus/6f56589e6857332bf408be13b2a1708e to your computer and use it in GitHub Desktop.
Save OnurGumus/6f56589e6857332bf408be13b2a1708e to your computer and use it in GitHub Desktop.
free monad
// Define the types for the inputs and outputs
type AccountID = AccountID of int
type Balance = Balance of decimal
type Deposit = Deposit of AccountID * decimal
type LogMessage = string
// Define an error type for your operations
type BankError =
| AccountNotFound of int
| InsufficientFunds of decimal
| DepositFailed of string
| LogError of string
// Add other error cases as needed
// Define the Free monad constructs including Log
type FaceInstruction<'a> =
| CheckBalance of AccountID * (Balance -> 'a)
| PerformDeposit of Deposit * (Balance -> 'a)
| Log of LogMessage * (unit -> 'a)
let private mapI f = function
| CheckBalance (x, next) -> CheckBalance (x, next >> f)
| PerformDeposit (x, next) -> PerformDeposit (x, next >> f)
| Log (msg, next) -> Log (msg, next >> f)
type FaceProgram<'a> =
| Free of FaceInstruction<FaceProgram<'a>>
| Pure of 'a
let rec bind f = function
| Free x -> Free (mapI (bind f) x)
| Pure x -> f x
type FaceBuilder () =
member _.Bind (x, f) = bind f x
member _.Return x = Pure x
member _.ReturnFrom x = x
member _.Zero () = Pure ()
let face = FaceBuilder ()
// Define operations using the FaceProgram type
let checkAccountBalance accountID = Free (CheckBalance (accountID, Pure))
let makeDeposit deposit = Free (PerformDeposit (deposit, Pure))
let log message = Free (Log (message, Pure)) // Log operation
open System
let bankOperations = face {
do! log "Starting bank operations"
let! initialBalance = checkAccountBalance (AccountID 1)
do! log (sprintf "Initial balance: %A" initialBalance)
let! postDepositBalance = makeDeposit (Deposit (AccountID 1, 50.0M))
do! log (sprintf "Balance after deposit: %A" postDepositBalance)
return postDepositBalance
}
//---- cut off
// Define mock implementations for the operations as async functions returning Result
let getAccountBalance (AccountID id) : Async<Result<Balance, BankError>> = async {
// Simulate asynchronous operation
do! Async.Sleep 100
match id with
| 1 -> return Ok (Balance 100.0M)
| _ -> return Error (AccountNotFound id)
}
let processDeposit (Deposit (id, amount)) : Async<Result<Balance, BankError>> = async {
// Simulate asynchronous operation
do! Async.Sleep 100
match id with
| AccountID 1 -> return Ok (Balance (100.0M + amount))
| _ -> return Error (DepositFailed $"Account {id} not found.")
}
let logMessage (msg : LogMessage) : Async<Result<unit, BankError>> = async {
// Simulate asynchronous logging
do! Async.Sleep 50
try
printfn "%s" msg
return Ok ()
with ex ->
return Error (LogError ex.Message)
}
// Define the interpreter for the operations including handling for Log
let rec interpret (program : FaceProgram<'a>) : Async<Result<'a, BankError>> =
async {
match program with
| Pure x -> return Ok x
| Free (CheckBalance (accountID, next)) ->
let! result = getAccountBalance accountID
match result with
| Ok balance ->
return! interpret (next balance)
| Error e -> return Error e
| Free (PerformDeposit (deposit, next)) ->
let! result = processDeposit deposit
match result with
| Ok newBalance ->
return! interpret (next newBalance)
| Error e -> return Error e
| Free (Log (message, next)) ->
let! result = logMessage message
match result with
| Ok () ->
return! interpret (next ())
| Error e -> return Error e
}
// Use the computation expression to define a bank operation workflow
// Run the bank operations and print the result
async {
let! result = interpret bankOperations
match result with
| Ok finalBalance ->
printfn "Final result: %A" finalBalance
| Error error ->
printfn "An error occurred: %A" error
return ()
} |> Async.StartImmediate
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment