Skip to content

Instantly share code, notes, and snippets.

@eulerfx
eulerfx / Async.Race.fs
Created June 21, 2018 20:58
F# Async Race
let race (a:Async<'a>) (b:Async<'a>) : Async<'a * Async<'a>> = async {
return!
Async.FromContinuations <| fun (ok,err,cnc) ->
let state = ref 0
let iv = new TaskCompletionSource<_>()
let ok a =
if (Interlocked.CompareExchange(state, 1, 0) = 0) then
ok (a, iv.Task |> Async.AwaitTask)
else
iv.SetResult a
@eulerfx
eulerfx / Async.Cache.fs
Last active June 27, 2018 14:26
F# Async Cache
let cache (a:Async<'a>) : Async<'a> =
let tcs = TaskCompletionSource<'a>()
let state = ref 0
async {
if (Interlocked.CompareExchange(state, 1, 0) = 0) then
Async.StartWithContinuations(
a,
tcs.SetResult,
tcs.SetException,
(fun _ -> tcs.SetCanceled()))
@eulerfx
eulerfx / Async.Timeout.fs
Created June 21, 2018 20:53
F# Async Timeout
let timeoutNone (timeoutMs:int) (a:Async<'a>) : Async<'a option> = async {
let! ct = Async.CancellationToken
let res = TaskCompletionSource<_>()
use cts = CancellationTokenSource.CreateLinkedTokenSource ct
res.Task.ContinueWith (fun _ -> cts.Cancel ()) |> ignore
use timer = new Timer((fun _ -> res.TrySetResult None |> ignore), null, timeoutMs, Timeout.Infinite)
Async.StartThreadPoolWithContinuations (
a,
(fun a -> res.TrySetResult (Some a) |> ignore),
(fun e -> res.TrySetException e |> ignore),
@eulerfx
eulerfx / Async.WithCancellation.fs
Created June 21, 2018 20:45
F# Async Cancellation Helper
let withCancellation (ct:CancellationToken) (a:Async<'a>) : Async<'a> = async {
let! ct2 = Async.CancellationToken
use cts = CancellationTokenSource.CreateLinkedTokenSource (ct, ct2)
let tcs = new TaskCompletionSource<'a>()
use _reg = cts.Token.Register (fun () -> tcs.TrySetCanceled() |> ignore)
let a = async {
try
let! a = a
tcs.TrySetResult a |> ignore
with ex ->
@eulerfx
eulerfx / EventStore.fs
Created May 31, 2018 19:37
Sample of polling reader of EventStore.ClientAPI in F#
// https://github.com/fsprojects/FSharp.Control.AsyncSeq
// RetryPolicy from https://github.com/jet/kafunk/blob/master/src/kafunk/Utility/Faults.fs#L89
/// Returns an Async computation which evaluates the input computation until the specified condition is met
/// with delays between attempts dictated by the specified retry policy.
let pollUntil (rp:RetryPolicy) (condition:'a -> bool) (a:Async<'a>) : Async<'a option> =
(AsyncSeq.replicateInfiniteAsync a, RetryPolicy.delayStream rp)
||> AsyncSeq.interleaveChoice
|> AsyncSeq.tryPick (function Choice1Of2 a when condition a -> Some a | _ -> None)
@eulerfx
eulerfx / poisson.fs
Last active May 10, 2018 14:37
F# Poisson process
open System
open System.Threading
let private disposable (dispose:unit -> unit) =
{ new IDisposable with member __.Dispose () = dispose () }
/// Creates an observable which triggers based on intervals specified by the input sequence.
let ofDelays (delays:TimeSpan seq) : IObservable<DateTimeOffset> =
{ new IObservable<_> with
member __.Subscribe obs =
let ParallelThrottledIgnore (startOnCallingThread:bool) (parallelism:int) (xs:seq<Async<_>>) = async {
let! ct = Async.CancellationToken
let sm = new SemaphoreSlim(parallelism)
let count = ref 1
let res = TaskCompletionSource<_>()
let tryWait () =
try sm.Wait () ; true
with _ -> false
let tryComplete () =
if Interlocked.Decrement count = 0 then
@eulerfx
eulerfx / learner.fs
Created December 28, 2017 16:40
A category of learners with backpropagation in F#
/// A learner for function type 'a -> 'b.
type Learner<'p, 'a, 'b> = {
/// An function parameterized by 'p implementing 'a -> 'b.
i : 'p * 'a -> 'b
/// Updates the parameter 'p based on training pair ('a,'b).
u : 'p * 'a * 'b -> 'p
/// Requests an input 'a based on parameter 'p and training pair ('a,'b).
type ExecContext () =
class
// TODO: scheduler, storage
end
[<AbstractClass>]
type Cont<'a> () =
abstract RunCont : ExecContext * 'a -> unit
[<AbstractClass>]
@eulerfx
eulerfx / universal_construction.fs
Created October 15, 2017 21:52
Universal Construction
open Marvel
open System.Collections.Concurrent
open System.Collections.Generic
type Pid = int
type Op = {
op : string
sn : SN
}