Skip to content

Commit

Permalink
+ ptraverse and psequence
Browse files Browse the repository at this point in the history
  • Loading branch information
@gusty
gusty committed Jan 21, 2024
1 parent c071bae commit 28d6e4f
Show file tree
Hide file tree
Showing 5 changed files with 310 additions and 2 deletions.
2 changes: 2 additions & 0 deletions src/FSharpPlus/Control/MonadOps.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,8 @@ module internal MonadOps =
let inline (>>=) x f = Bind.Invoke x f
let inline result x = Return.Invoke x
let inline (<*>) f x = Apply.Invoke f x
let inline presult x = ParReturn.Invoke x
let inline (</>) f x = ParApply.Invoke f x
let inline (<|>) x y = Append.Invoke x y
let inline (>=>) (f: 'a->'``Monad<'b>``) (g: 'b->'``Monad<'c>``) (x: 'a) : '``Monad<'c>`` = f x >>= g

Expand Down
17 changes: 16 additions & 1 deletion src/FSharpPlus/Control/Parallel.fs
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
namespace FSharpPlus.Control

open System
open System.Text
open System.Runtime.InteropServices
open System.Collections.Generic
open System.Threading.Tasks
Expand Down Expand Up @@ -53,6 +54,15 @@ type ParReturn =
[<CompilerMessage("No parallel applicative Return operation for ResizeArray<'t>", 10720, IsError = true)>]
static member ParReturn (x: ResizeArray<'a>, _: ParReturn ) = Return.Return (x, Unchecked.defaultof<Return>)

//Restricted
[<CompilerMessage("No parallel applicative Return operation for string", 10720, IsError = true)>]
static member ParReturn (_: string , _: ParReturn ) = fun (x: char) -> string x : string
[<CompilerMessage("No parallel applicative Return operation for StringBuilder", 10720, IsError = true)>]
static member ParReturn (_: StringBuilder , _: ParReturn ) = fun (x: char) -> new StringBuilder (string x) : StringBuilder
[<CompilerMessage("No parallel applicative Return operation for Set", 10720, IsError = true)>]
static member ParReturn (_: 'a Set , _: ParReturn ) = fun (x: 'a ) -> Set.singleton x
static member ParReturn (_: 'a Set2 , _: ParReturn ) = fun (_: 'a ) -> Set2() : 'a Set2

#endif

type ParApply =
Expand Down Expand Up @@ -80,7 +90,12 @@ type ParApply =
static member ``</>`` (struct (f: voption<_> , x: voption<'T> ), [<Optional>]_output: voption<'U> , [<Optional>]_mthd: ParApply) = Apply.``<*>`` (struct (f, x), _output, Unchecked.defaultof<Apply>)
static member inline ``</>`` (struct (f: Result<_,'E> , x: Result<'T,'E> ), [<Optional>]_output: Result<'b,'E> , [<Optional>]_mthd: ParApply) : Result<'U, 'E> = Result.apply2With Plus.Invoke (<|) f x
static member inline ``</>`` (struct (f: Choice<_,'E> , x: Choice<'T,'E> ), [<Optional>]_output: Choice<'b,'E> , [<Optional>]_mthd: ParApply) : Choice<'U, 'E> = Choice.apply2With Plus.Invoke (<|) f x
static member inline ``</>`` (struct (f: KeyValuePair<'Key,_>, x: KeyValuePair<'Key,'T>), [<Optional>]_output: KeyValuePair<'Key,'U>, [<Optional>]_mthd: ParApply) = Apply.``<*>`` (struct (f, x), _output, Unchecked.defaultof<Apply>)
static member inline ``</>`` (struct (f: KeyValuePair<'Key,_>, x: KeyValuePair<'Key,'T>), [<Optional>]_output: KeyValuePair<'Key,'U>, [<Optional>]_mthd: Default2) = Apply.``<*>`` (struct (f, x), _output, Unchecked.defaultof<Apply>)
static member inline ``</>`` (struct (f: KeyValuePair2<_,_>, x: KeyValuePair2<_,'T> ) , _output: KeyValuePair2<_,'U> , _mthd: Default2) : KeyValuePair2<'Key,'U> =
let a, b = f.Key, x.Key
let f, x = f.Value, x.Value
KeyValuePair2 (Plus.Invoke a b, f x)


static member ``</>`` (struct (f: Map<'Key,_> , x: Map<'Key,'T> ), [<Optional>]_output: Map<'Key,'U> , [<Optional>]_mthd: ParApply) : Map<'Key,'U> = Apply.``<*>`` (struct (f, x), _output, Unchecked.defaultof<Apply>)
static member ``</>`` (struct (f: Dictionary<'Key,_> , x: Dictionary<'Key,'T> ), [<Optional>]_output: Dictionary<'Key,'U> , [<Optional>]_mthd: ParApply) : Dictionary<'Key,'U> = Apply.``<*>`` (struct (f, x), _output, Unchecked.defaultof<Apply>)
Expand Down
245 changes: 244 additions & 1 deletion src/FSharpPlus/Control/Traversable.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -244,4 +244,247 @@ type Sequence with
let inline call (a: 'a, b: 'b) = call_3 (a, b, Unchecked.defaultof<'R>) : 'R
call (Unchecked.defaultof<Sequence>, t)

#endif


// Parallel traversables


type ParSequence =
inherit Default1
static member inline InvokeOnInstance (t: '``ParTraversable<'Functor<'T>>``) = (^``ParTraversable<'Functor<'T>>`` : (static member ParSequence : _ -> _) t) : '``Functor<'ParTraversable<'T>>``

[<EditorBrowsable(EditorBrowsableState.Never)>]
static member inline ForInfiniteSequences (t: seq<_>, isFailure, conversion) =
let add x y = y :: x
let mutable go = true
let mutable r = Unchecked.defaultof<_>
let mutable isEmpty = true
use e = t.GetEnumerator ()
while go && e.MoveNext () do
if isFailure e.Current then go <- false
if isEmpty then r <- Map.Invoke List.singleton e.Current
else r <- Map.Invoke add r </> e.Current
isEmpty <- false
if isEmpty then ParReturn.Invoke (conversion [])
else Map.Invoke (List.rev >> conversion) r

type ParTraverse =
inherit Default1
static member inline InvokeOnInstance f (t: ^a) = (^a : (static member ParTraverse : _ * _ -> 'R) t, f)

static member inline ParTraverse (t: '``ParTraversable<'T>``, f: 'T -> '``Functor<'U>``, [<Optional>]_output: '``Functor<'ParTraversable<'U>>``, [<Optional>]_impl: Default4) =
#if TEST_TRACE
Traces.add "ParTraverse 'ParTraversable, 'T -> Functor<'U>"
#endif
let mapped = Map.Invoke f t : '``ParTraversable<'Functor<'U>>``
(^``ParTraversable<'T>`` : (static member ParSequence : _ -> _) mapped) : '``Functor<'ParTraversable<'U>>``

static member inline ParTraverse (t: Id<_>, f, [<Optional>]_output: 'R, [<Optional>]_impl: Default3) =
#if TEST_TRACE
Traces.add "ParTraverse Id"
#endif
Map.Invoke Id.create (f (Id.run t))

static member inline ParTraverse (t: _ seq, f, [<Optional>]_output: 'R, [<Optional>]_impl: Default3) =
#if TEST_TRACE
Traces.add "ParTraverse seq"
#endif
let cons x y = seq {yield x; yield! y}
let cons_f x ys = Map.Invoke (cons: 'a -> seq<_> -> seq<_>) (f x) </> ys
Seq.foldBack cons_f t (ParReturn.Invoke Seq.empty)

static member inline ParTraverse (t: _ NonEmptySeq, f, [<Optional>]_output: 'R, [<Optional>]_impl: Default3) =
#if TEST_TRACE
Traces.add "ParTraverse NonEmptySeq"
#endif
let cons x y = seq {yield x; yield! y}
let cons_f x ys = Map.Invoke (cons: 'a -> seq<_> -> seq<_>) (f x) </> ys
Map.Invoke NonEmptySeq.ofSeq (Seq.foldBack cons_f t (ParReturn.Invoke Seq.empty))

static member inline ParTraverse (t: seq<'T>, f: 'T -> '``Functor<'U>``, [<Optional>]_output: '``Functor<seq<'U>>``, [<Optional>]_impl: Default2) =
#if TEST_TRACE
Traces.add "ParTraverse seq, 'T -> Functor<'U>"
#endif
let mapped = Seq.map f t
ParSequence.ForInfiniteSequences (mapped, IsParLeftZero.Invoke, List.toSeq) : '``Functor<seq<'U>>``

static member inline ParTraverse (t: NonEmptySeq<'T>, f: 'T -> '``Functor<'U>``, [<Optional>]_output: '``Functor<NonEmptySeq<'U>>``, [<Optional>]_impl: Default2) =
#if TEST_TRACE
Traces.add "ParTraverse NonEmptySeq, 'T -> Functor<'U>"
#endif
let mapped = NonEmptySeq.map f t
ParSequence.ForInfiniteSequences (mapped, IsParLeftZero.Invoke, NonEmptySeq.ofList) : '``Functor<NonEmptySeq<'U>>``

static member inline ParTraverse (t: ^a, f, [<Optional>]_output: 'R, [<Optional>]_impl: Default1) : 'R =
#if TEST_TRACE
Traces.add "ParTraverse ^a"
#endif
ParTraverse.InvokeOnInstance f t
static member inline ParTraverse (_: ^a when ^a : null and ^a :struct, _, _: 'R, _impl: Default1) = id

#if !FABLE_COMPILER
static member ParTraverse (t: 't seq, f: 't -> Async<'u>, [<Optional>]_output: Async<seq<'u>>, [<Optional>]_impl: ParTraverse) : Async<seq<_>> = async {
#if TEST_TRACE
Traces.add "ParTraverse 't seq, 't -> Async<'u>"
#endif

let! ct = Async.CancellationToken
return seq {
use enum = t.GetEnumerator ()
while enum.MoveNext() do
yield Async.RunSynchronously (f enum.Current, cancellationToken = ct) }}
#endif

#if !FABLE_COMPILER
static member ParTraverse (t: 't NonEmptySeq, f: 't -> Async<'u>, [<Optional>]_output: Async<NonEmptySeq<'u>>, [<Optional>]_impl: ParTraverse) : Async<NonEmptySeq<_>> = async {
#if TEST_TRACE
Traces.add "ParTraverse 't NonEmptySeq, 't -> Async<'u>"
#endif

let! ct = Async.CancellationToken
return seq {
use enum = t.GetEnumerator ()
while enum.MoveNext() do
yield Async.RunSynchronously (f enum.Current, cancellationToken = ct) } |> NonEmptySeq.unsafeOfSeq }
#endif

static member ParTraverse (t: Id<'t>, f: 't -> option<'u>, [<Optional>]_output: option<Id<'u>>, [<Optional>]_impl: ParTraverse) =
#if TEST_TRACE
Traces.add "ParTraverse Id, 't -> option<'u>"
#endif
Option.map Id.create (f (Id.run t))

static member inline ParTraverse (t: option<_>, f, [<Optional>]_output: 'R, [<Optional>]_impl: ParTraverse) : 'R =
#if TEST_TRACE
Traces.add "ParTraverse option"
#endif
match t with Some x -> Map.Invoke Some (f x) | _ -> ParReturn.Invoke None

static member inline ParTraverse (t: voption<_>, f, [<Optional>]_output: 'R, [<Optional>]_impl: ParTraverse) : 'R =
#if TEST_TRACE
Traces.add "ParTraverse voption"
#endif
match t with ValueSome x -> Map.Invoke ValueSome (f x) | _ -> ParReturn.Invoke ValueNone

static member inline ParTraverse (t:Map<_,_> , f, [<Optional>]_output: 'R, [<Optional>]_impl: ParTraverse) : 'R =
#if TEST_TRACE
Traces.add "ParTraverse Map"
#endif
let insert_f m k v = Map.Invoke (Map.add k) v </> m
Map.fold insert_f (ParReturn.Invoke Map.empty) (Map.mapValues f t)

static member inline ParTraverse (t: Result<'T,'Error>, f: 'T -> '``Functor<'U>``, [<Optional>]_output: '``Functor<Result<'U, 'Error>>``, [<Optional>]_impl: ParTraverse) : '``Functor<Result<'U, 'Error>>`` =
#if TEST_TRACE
Traces.add "ParTraverse Result, 'T -> Functor<'U>"
#endif
match t with
| Ok a -> Map.Invoke Result<'U, 'Error>.Ok (f a)
| Error e -> ParReturn.Invoke (Result<'U, 'Error>.Error e)

static member inline ParTraverse (t: Choice<'T,'Error>, f: 'T -> '``Functor<'U>``, [<Optional>]_output: '``Functor<Choice<'U, 'Error>>``, [<Optional>]_impl: ParTraverse) : '``Functor<Choice<'U, 'Error>>`` =
#if TEST_TRACE
Traces.add "ParTraverse Choice, 'T -> Functor<'U>"
#endif
match t with
| Choice1Of2 a -> Map.Invoke Choice<'U,'Error>.Choice1Of2 (f a)
| Choice2Of2 e -> ParReturn.Invoke (Choice<'U,'Error>.Choice2Of2 e)

static member inline ParTraverse (t:list<_>,f , [<Optional>]_output: 'R, [<Optional>]_impl: ParTraverse) : 'R =
#if TEST_TRACE
Traces.add "ParTraverse list"
#endif
let rec loop acc = function
| [] -> acc
| x::xs ->
let v = f x
loop (v::acc) xs
let cons_f x xs = Map.Invoke List.cons xs </> x
List.fold cons_f (ParReturn.Invoke []) (loop [] t)

static member inline ParTraverse (t:_ [],f , [<Optional>]_output: 'R, [<Optional>]_impl: ParTraverse) : 'R =
#if TEST_TRACE
Traces.add "ParTraverse []"
#endif
let cons x y = Array.append [|x|] y
let rec loop acc = function
| [||] -> acc
| xxs ->
let x, xs = Array.head xxs, Array.tail xxs
let v = f x
loop (cons v acc) xs
let cons_f x xs = Map.Invoke cons xs </> x
Array.fold cons_f (ParReturn.Invoke [||]) (loop [||] t)

static member inline Invoke (f: 'T -> '``Functor<'U>``) (t: '``ParTraversable<'T>``) : '``Functor<'ParTraversable<'U>>`` =
let inline call_3 (a: ^a, b: ^b, c: ^c, f) = ((^a or ^b or ^c) : (static member ParTraverse : _*_*_*_ -> _) b, f, c, a)
let inline call (a: 'a, b: 'b, f) = call_3 (a, b, Unchecked.defaultof<'R>, f) : 'R
call (Unchecked.defaultof<ParTraverse>, t, f)


type ParSequence with

static member inline ParSequence (t: _ seq, [<Optional>]_output: 'R, [<Optional>]_impl: Default5) : 'R =
let cons x y = seq { yield x; yield! y }
let cons_f x ys = Map.Invoke (cons: 'a -> seq<_> -> seq<_>) x </> ys
Seq.foldBack cons_f t (ParReturn.Invoke Seq.empty)

static member inline ParSequence (t: seq<'``Applicative<'T>``>, [<Optional>]_output: '``Applicative<seq<'T>>`` , [<Optional>]_impl: Default4) : '``Applicative<seq<'T>>`` =
ParSequence.ForInfiniteSequences (t, IsParLeftZero.Invoke, List.toSeq)

static member ParSequence (t: seq<option<'t>> , [<Optional>]_output: option<seq<'t>> , [<Optional>]_impl: Default3) : option<seq<'t>> = Option.Sequence t
#if !FABLE_COMPILER
static member ParSequence (t: seq<voption<'t>> , [<Optional>]_output: voption<seq<'t>> , [<Optional>]_impl: Default3) : voption<seq<'t>> = ValueOption.Sequence t
#endif
static member inline ParSequence (t: seq<Result<'t,'e>>, [<Optional>]_output: Result<seq<'t>, 'e>, [<Optional>]_impl: Default3) : Result<seq<'t>, 'e> = Result.Parallel ((++), t)
static member inline ParSequence (t: seq<Choice<'t,'e>>, [<Optional>]_output: Choice<seq<'t>, 'e>, [<Optional>]_impl: Default3) : Choice<seq<'t>, 'e> = Choice.Parallel ((++), t)
static member ParSequence (t: seq<list<'t>> , [<Optional>]_output: list<seq<'t>> , [<Optional>]_impl: Default3) : list<seq<'t>> = ParSequence.ForInfiniteSequences (t, List.isEmpty, List.toSeq)
// static member ParSequence (t: seq<'t []> , [<Optional>]_output: seq<'t> [] , [<Optional>]_impl: Default3) : seq<'t> [] = ParSequence.ForInfiniteSequences (t, Array.isEmpty, List.toSeq)

#if !FABLE_COMPILER
static member ParSequence (t: seq<Async<'t>> , [<Optional>]_output: Async<seq<'t>> , [<Optional>]_impl: Default3) : Async<seq<'t>> = Async.Parallel t |> Async.map Array.toSeq
#endif
static member inline ParSequence (t: NonEmptySeq<'``Applicative<'T>``>, [<Optional>]_output: '``Applicative<NonEmptySeq<'T>>`` , [<Optional>]_impl: Default4) : '``Applicative<NonEmptySeq<'T>>`` = ParSequence.ForInfiniteSequences (t, IsParLeftZero.Invoke, NonEmptySeq.ofList)
static member ParSequence (t: NonEmptySeq<option<'t>> , [<Optional>]_output: option<NonEmptySeq<'t>> , [<Optional>]_impl: Default3) : option<NonEmptySeq<'t>> = Option.Sequence t |> Option.map NonEmptySeq.unsafeOfSeq
static member inline ParSequence (t: NonEmptySeq<Result<'t,'e>>, [<Optional>]_output: Result<NonEmptySeq<'t>, 'e>, [<Optional>]_impl: Default3) : Result<NonEmptySeq<'t>, 'e> = Result.Parallel ((++), t) |> Result.map NonEmptySeq.unsafeOfSeq
static member inline ParSequence (t: NonEmptySeq<Choice<'t,'e>>, [<Optional>]_output: Choice<NonEmptySeq<'t>, 'e>, [<Optional>]_impl: Default3) : Choice<NonEmptySeq<'t>, 'e> = Choice.Parallel ((++), t) |> Choice.map NonEmptySeq.unsafeOfSeq
static member ParSequence (t: NonEmptySeq<list<'t>> , [<Optional>]_output: list<NonEmptySeq<'t>> , [<Optional>]_impl: Default3) : list<NonEmptySeq<'t>> = ParSequence.ForInfiniteSequences(t, List.isEmpty , NonEmptySeq.ofList)
// static member ParSequence (t: NonEmptySeq<'t []> , [<Optional>]_output: NonEmptySeq<'t> [] , [<Optional>]_impl: Default3) : NonEmptySeq<'t> [] = ParSequence.ForInfiniteSequences(t, Array.isEmpty, NonEmptySeq.ofList)
#if !FABLE_COMPILER
static member ParSequence (t: NonEmptySeq<Async<'t>> , [<Optional>]_output: Async<NonEmptySeq<'t>> , [<Optional>]_impl: Default3) = Async.Parallel t |> Async.map NonEmptySeq.unsafeOfSeq : Async<NonEmptySeq<'t>>
#endif

static member inline ParSequence (t: ^a , [<Optional>]_output: 'R, [<Optional>]_impl: Default2) : 'R = ParTraverse.InvokeOnInstance id t
static member inline ParSequence (t: ^a , [<Optional>]_output: 'R, [<Optional>]_impl: Default1) : 'R = ParSequence.InvokeOnInstance t

static member inline ParSequence (t: option<_> , [<Optional>]_output: 'R, [<Optional>]_impl: ParSequence) : 'R = match t with Some x -> Map.Invoke Some x | _ -> ParReturn.Invoke None
#if !FABLE_COMPILER
static member inline ParSequence (t: voption<_>, [<Optional>]_output: 'R, [<Optional>]_impl: ParSequence) : 'R = match t with ValueSome x -> Map.Invoke ValueSome x | _ -> ParReturn.Invoke ValueNone
#endif
static member inline ParSequence (t: list<_> , [<Optional>]_output: 'R, [<Optional>]_impl: ParSequence) : 'R = ParSequence.ForInfiniteSequences(t, IsParLeftZero.Invoke, id)

static member inline ParSequence (t: Map<_,_> , [<Optional>]_output: 'R, [<Optional>]_impl: ParSequence) : 'R =
let insert_f k x ys = Map.Invoke (Map.add k) x </> ys
Map.foldBack insert_f t (ParReturn.Invoke Map.empty)

static member inline ParSequence (t: Result<'``Functor<'T>``,'Error>, [<Optional>]_output: '``Functor<Result<'T,'Error>>``, [<Optional>]_impl: ParSequence) : '``Functor<Result<'T,'Error>>`` =
match t with
| Ok a -> Map.Invoke Result<'T,'Error>.Ok a
| Error e -> ParReturn.Invoke (Result<'T,'Error>.Error e)

static member inline ParSequence (t: Choice<'``Functor<'T>``,'Error>, [<Optional>]_output: '``Functor<Choice<'T,'Error>>``, [<Optional>]_impl: ParSequence) : '``Functor<Choice<'T,'Error>>`` =
match t with
| Choice1Of2 a -> Map.Invoke Choice<'T,'Error>.Choice1Of2 a
| Choice2Of2 e -> ParReturn.Invoke (Choice<'T,'Error>.Choice2Of2 e)

static member inline ParSequence (t: _ [] , [<Optional>]_output: 'R , [<Optional>]_impl: ParSequence) : 'R = ParSequence.ForInfiniteSequences(t, IsParLeftZero.Invoke, Array.ofList)

static member inline ParSequence (t: Id<'``Functor<'T>``> , [<Optional>]_output: '``Functor<Id<'T>>`` , [<Optional>]_impl: ParSequence) : '``Functor<Id<'T>>`` = ParTraverse.Invoke id t

static member inline ParSequence (t: ResizeArray<'``Functor<'T>``>, [<Optional>]_output: '``Functor<ResizeArray<'T>>`` , [<Optional>]_impl: ParSequence) : '``Functor<ResizeArray<'T>>``= ParTraverse.Invoke id t

static member inline Invoke (t: '``ParTraversable<'Applicative<'T>>``) : '``Applicative<'ParTraversable<'T>>`` =
let inline call_3 (a: ^a, b: ^b, c: ^c) = ((^a or ^b or ^c) : (static member ParSequence : _*_*_ -> _) b, c, a)
let inline call (a: 'a, b: 'b) = call_3 (a, b, Unchecked.defaultof<'R>) : 'R
call (Unchecked.defaultof<ParSequence>, t)

#endif
Loading

0 comments on commit 28d6e4f

Please sign in to comment.