Skip to content

Commit

Permalink
Use monadic sequencing instead of applicative in all monads (#1)
Browse files Browse the repository at this point in the history 

Co-authored-by: Jamil Maqdis Anton <jamil.maqdis-anton@insurello.se>
  • Loading branch information
@jamil7
jamil7 and Jamil Maqdis Anton authored Apr 10, 2021
1 parent cb311ff commit fbaabd3
Show file tree
Hide file tree
Showing 9 changed files with 711 additions and 419 deletions.
159 changes: 93 additions & 66 deletions src/Async.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,19 +2,20 @@ namespace FSharp.Prelude.Operators.Async

[<AutoOpen>]
module AsyncOperators =

/// Infix map operator.
let inline (<!>) (f: 'a -> 'b) (asyncOp: Async<'a>): Async<'b> = async.Bind(asyncOp, f >> async.Return)
let inline (<!>) (f: 'a -> 'b) (asyncOp: Async<'a>) : Async<'b> = async.Bind(asyncOp, f >> async.Return)

/// Infix apply operator.
let inline (<*>) (f: Async<('a -> 'b)>) (asyncOp: Async<'a>): Async<'b> =
let inline (<*>) (f: Async<'a -> 'b>) (asyncOp: Async<'a>) : Async<'b> =
async {
let! f' = f
let! asyncOp' = asyncOp
return f' asyncOp'
}

/// Infix parallel apply operator.
let inline (<&>) (f: Async<('a -> 'b)>) (asyncOp: Async<'a>): Async<'b> =
let inline (<&>) (f: Async<'a -> 'b>) (asyncOp: Async<'a>) : Async<'b> =
async {
let! runF = Async.StartChildAsTask f
let! runAsyncOp = Async.StartChildAsTask asyncOp
Expand All @@ -24,96 +25,122 @@ module AsyncOperators =
}

/// Infix bind operator.
let inline (>>=) (f: 'a -> Async<'b>) (asyncOp: Async<'a>): Async<'b> = async.Bind(asyncOp, f)
let inline (>>=) (asyncOp: Async<'a>) (f: 'a -> Async<'b>) : Async<'b> = async.Bind(asyncOp, f)


namespace FSharp.Prelude

open FSharp.Prelude.Operators.Async
open System.Threading.Tasks

[<RequireQualifiedAccess>]
module Async =

open FSharp.Prelude.Operators.Async

/// Wraps a value in an Async.
let singleton (value: 'a): Async<'a> = async.Return(value)
let singleton (value: 'a) : Async<'a> = async.Return value

let map (f: 'a -> 'b) (asyncOp: Async<'a>) : Async<'b> = f <!> asyncOp

let apply (f: Async<'a -> 'b>) (asyncOp: Async<'a>) : Async<'b> = f <*> asyncOp

let applyParallel (f: Async<'a -> 'b>) (asyncOp: Async<'a>) : Async<'b> = f <&> asyncOp

let map (f: 'a -> 'b) (asyncOp: Async<'a>): Async<'b> = f <!> asyncOp
let bind (f: 'a -> Async<'b>) (asyncOp: Async<'a>) : Async<'b> = asyncOp >>= f

let apply (f: Async<('a -> 'b)>) (asyncOp: Async<'a>): Async<'b> = f <*> asyncOp
let map2 (f: 'a -> 'b -> 'c) (asyncOp1: Async<'a>) (asyncOp2: Async<'b>) : Async<'c> = f <!> asyncOp1 <*> asyncOp2

let applyParallel (f: Async<('a -> 'b)>) (asyncOp: Async<'a>): Async<'b> = f <&> asyncOp
let andMap (asyncOp: Async<'a>) (f: Async<'a -> 'b>) : Async<'b> = map2 (|>) asyncOp f

let bind (f: 'a -> Async<'b>) (asyncOp: Async<'a>): Async<'b> = f >>= asyncOp
let internal traverseM (f: 'a -> Async<'b>) (asyncOps: 'a list) : Async<'b list> =
List.foldBack
(fun head tail ->
f head
>>= (fun head' ->
tail
>>= (fun tail' -> singleton ((fun h t -> h :: t) head' tail'))))
asyncOps
(singleton [])

let map2 (f: 'a -> 'b -> 'c) (asyncOp1: Async<'a>) (asyncOp2: Async<'b>): Async<'c> = f <!> asyncOp1 <*> asyncOp2
let internal traverseA (f: 'a -> Async<'b>) (asyncOps: 'a list) : Async<'b list> =
List.foldBack (fun head tail -> (fun h t -> h :: t) <!> f head <*> tail) asyncOps (singleton [])

let andMap (asyncOp: Async<'a>) (f: Async<('a -> 'b)>): Async<'b> = map2 (|>) asyncOp f
let internal traverseAParallel (f: 'a -> Async<'b>) (asyncOps: 'a list) : Async<'b list> =
List.foldBack (fun head tail -> (fun h t -> h :: t) <!> f head <&> tail) asyncOps (singleton [])

let private traverser (f: Async<('b list -> 'b list)> -> Async<'b list> -> Async<'b list>)
(g: 'a -> Async<'b>)
(list: 'a list)
: Async<'b list> =
List.foldBack (fun head tail ->
(fun head' tail' -> head' :: tail') <!> (g head)
|> f
<| tail) list (singleton [])
let internal sequenceM (asyncOps: Async<'a> list) : Async<'a list> = traverseM id asyncOps

let traverse (f: 'a -> Async<'b>) (list: 'a list): Async<'b list> = traverser (<*>) f list
let internal sequenceA (asyncOps: Async<'a> list) : Async<'a list> = traverseA id asyncOps

let traverseParallel (f: 'a -> Async<'b>) (list: 'a list): Async<'b list> = traverser (<&>) f list
let internal sequenceAParallel (asyncOps: Async<'a> list) : Async<'a list> = traverseAParallel id asyncOps

let sequence (asyncOps: Async<'a> list): Async<'a list> = traverse id asyncOps
let sequence (asyncOps: Async<'a> list) : Async<'a list> = sequenceM asyncOps

let parallel' (asyncOps: Async<'a> list): Async<'a list> =
let parallel' (asyncOps: Async<'a> list) : Async<'a list> =
async {
let! resArray = Async.Parallel asyncOps
return List.ofArray resArray
}

let private zipper f (asyncOp1: Async<'a>) (asyncOp2: Async<'b>): Async<'a * 'b> =
(fun a b -> a, b) <!> asyncOp1 |> f <| asyncOp2

let zip (asyncOp1: Async<'a>) (asyncOp2: Async<'b>): Async<'a * 'b> = zipper (<*>) asyncOp1 asyncOp2

let zipParallel (asyncOp1: Async<'a>) (asyncOp2: Async<'b>): Async<'a * 'b> = zipper (<&>) asyncOp1 asyncOp2

/// A replacement for Async.AwaitTask that throws inner exceptions if they exist.
let awaitTaskWithInnerException (task: Task<'T>): Async<'T> =
Async.FromContinuations(fun (success, exception', _cancellationToken) ->
task.ContinueWith(fun (t: Task<'T>) ->
if t.IsFaulted then
if t.Exception.InnerExceptions.Count = 1
then exception' t.Exception.InnerExceptions.[0]
else exception' t.Exception
elif t.IsCanceled then
exception' (TaskCanceledException())
else
success t.Result)
|> ignore)

/// A replacement for Async.AwaitTask that throws inner exceptions if they exist.
let awaitUnitTaskWithInnerException (task: Task): Async<unit> =
Async.FromContinuations(fun (success, exception', _cancellationToken) ->
task.ContinueWith(fun (t: Task) ->
if t.IsFaulted then
if t.Exception.InnerExceptions.Count = 1
then exception' t.Exception.InnerExceptions.[0]
else exception' t.Exception
elif t.IsCanceled then
exception' (TaskCanceledException())
else
success ())
|> ignore)
let zip (asyncOp1: Async<'a>) (asyncOp2: Async<'b>) : Async<'a * 'b> =
(fun a b -> a, b) <!> asyncOp1 <*> asyncOp2

let zipParallel (asyncOp1: Async<'a>) (asyncOp2: Async<'b>) : Async<'a * 'b> =
(fun a b -> a, b) <!> asyncOp1 <&> asyncOp2


[<AutoOpen>]
module AsyncExtension =

open System.Threading.Tasks

type Async with
/// A replacement for Async.AwaitTask that throws inner exceptions if they exist.
static member AwaitTaskWithInnerException(task: Task<'T>) : Async<'T> =
Async.FromContinuations
(fun (success, exception', _cancellationToken) ->
task.ContinueWith
(fun (t: Task<'T>) ->
if t.IsFaulted then
if t.Exception.InnerExceptions.Count = 1 then
exception' t.Exception.InnerExceptions.[0]
else
exception' t.Exception
elif t.IsCanceled then
exception' (TaskCanceledException())
else
success t.Result)
|> ignore)

/// A replacement for Async.AwaitTask that throws inner exceptions if they exist.
static member AwaitTaskWithInnerException(task: Task) : Async<unit> =
Async.FromContinuations
(fun (success, exception', _cancellationToken) ->
task.ContinueWith
(fun (t: Task) ->
if t.IsFaulted then
if t.Exception.InnerExceptions.Count = 1 then
exception' t.Exception.InnerExceptions.[0]
else
exception' t.Exception
elif t.IsCanceled then
exception' (TaskCanceledException())
else
success ())
|> ignore)


[<AutoOpen>]
module AsyncCEExtensions =

open System.Threading.Tasks

type FSharp.Control.AsyncBuilder with
member _.Bind(task: Task<'a>, f: 'a -> Async<'b>): Async<'b> =
Async.bind f (Async.awaitTaskWithInnerException task)
member this.Bind(task: Task<'a>, f: 'a -> Async<'b>) : Async<'b> =
Async.bind f (Async.AwaitTaskWithInnerException task)

member _.Bind(task: Task, f: unit -> Async<unit>): Async<unit> =
Async.bind f (Async.awaitUnitTaskWithInnerException task)
member this.Bind(actionTask: Task, f: unit -> Async<unit>) : Async<unit> =
Async.bind f (Async.AwaitTaskWithInnerException actionTask)

member _.BindReturn(asyncOption: Async<'a>, f: 'a -> 'b): Async<'b> = Async.map f asyncOption
member this.BindReturn(async: Async<'a>, f: 'a -> 'b) : Async<'b> = Async.map f async

member _.MergeSources(async1: Async<'a>, async2: Async<'b>): Async<'a * 'b> = Async.zipParallel async1 async2
member this.MergeSources(async1: Async<'a>, async2: Async<'b>) : Async<'a * 'b> =
Async.zipParallel async1 async2
Loading

0 comments on commit fbaabd3

Please sign in to comment.