Tail rec traverse and sequence + changes (#3)

jamil7 · May 6, 2021 · 13b5581 · 13b5581
1 parent b6bbeb9
commit 13b5581
Show file tree

Hide file tree

Showing 12 changed files with 868 additions and 274 deletions.
diff --git a/src/Async.fs b/src/Async.fs
@@ -50,36 +50,6 @@ module Async =
 
     let andMap (asyncOp: Async<'a>) (f: Async<'a -> 'b>) : Async<'b> = map2 (|>) asyncOp f
 
-    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 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 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 internal sequenceM (asyncOps: Async<'a> list) : Async<'a list> = traverseM id asyncOps
-
-    let internal sequenceA (asyncOps: Async<'a> list) : Async<'a list> = traverseA id asyncOps
-
-    let internal sequenceAParallel (asyncOps: Async<'a> list) : Async<'a list> = traverseAParallel id asyncOps
-
-    let sequence (asyncOps: Async<'a> list) : Async<'a list> = sequenceM asyncOps
-
-    let parallel' (asyncOps: Async<'a> list) : Async<'a list> =
-        async {
-            let! resArray = Async.Parallel asyncOps
-            return List.ofArray resArray
-        }
-
     let zip (asyncOp1: Async<'a>) (asyncOp2: Async<'b>) : Async<'a * 'b> =
         (fun a b -> a, b) <!> asyncOp1 <*> asyncOp2
 

diff --git a/src/AsyncOption.fs b/src/AsyncOption.fs
@@ -29,19 +29,6 @@ module AsyncOptionOperators =
             | None -> Async.singleton None)
             asyncOption
 
-    let inline (>=>) (f: 'a -> Async<'b option>) (g: 'b -> Async<'c option>) : 'a -> Async<'c option> =
-        fun x ->
-            async {
-                let! f' = f x
-
-                let! g' =
-                    match f' with
-                    | Some thing -> g thing
-                    | None -> Async.singleton None
-
-                return g'
-            }
-
     let inline (<|>) (asyncOption1: Async<'a option>) (asyncOption2: Async<'a option>) : Async<'a Option> =
         Async.map2 Option.alternative asyncOption1 asyncOption2
 
@@ -75,38 +62,36 @@ module AsyncOption =
 
     let andMap (asyncOption: AsyncOption<'a>) (f: AsyncOption<'a -> 'b>) : AsyncOption<'b> = map2 (|>) asyncOption f
 
-    let compose (f: 'a -> Async<'b option>) (g: 'b -> Async<'c option>) : 'a -> Async<'c option> = f >=> g
+    let rec private traverser (f: 'a -> AsyncOption<'b>) folder state xs =
+        match xs with
+        | [] -> List.rev <!> state
+        | head :: tail ->
+            async {
+                match! folder head state with
+                | Some _ as this -> return! traverser f folder (Async.singleton this) tail
+                | None as this -> return this
+            }
 
-    let internal traverseM (f: 'a -> AsyncOption<'b>) (asyncOptions: 'a list) : AsyncOption<'b list> =
-        List.foldBack
-            (fun head tail ->
-                f head
-                >>= (fun head' ->
+    let mapM (f: 'a -> AsyncOption<'b>) (asyncOptions: 'a list) : AsyncOption<'b list> =
+        let folder head tail =
+            f head
+            >>= fun head' ->
                     tail
-                    >>= (fun tail' -> singleton ((fun h t -> h :: t) head' tail'))))
-            asyncOptions
-            (singleton [])
-
-    let internal traverseA (f: 'a -> AsyncOption<'b>) (asyncOptions: 'a list) : AsyncOption<'b list> =
-        List.foldBack (fun head tail -> (fun h t -> h :: t) <!> f head <*> tail) asyncOptions (singleton [])
+                    >>= fun tail' -> singleton <| cons head' tail'
 
-    let internal traverseAParallel (f: 'a -> AsyncOption<'b>) (asyncOptions: 'a list) : AsyncOption<'b list> =
-        List.foldBack (fun head tail -> (fun h t -> h :: t) <!> f head <&> tail) asyncOptions (singleton [])
+        traverser f folder (singleton []) asyncOptions
 
-    let internal sequenceM (asyncOptions: AsyncOption<'a> list) : AsyncOption<'a list> = traverseM id asyncOptions
+    let traverse (f: 'a -> AsyncOption<'b>) (asyncOptions: 'a list) : AsyncOption<'b list> =
+        traverser f (fun head tail -> cons <!> f head <*> tail) (singleton []) asyncOptions
 
-    let internal sequenceA (asyncOptions: AsyncOption<'a> list) : AsyncOption<'a list> = traverseA id asyncOptions
+    let traverseParallel (f: 'a -> AsyncOption<'b>) (asyncOptions: 'a list) : AsyncOption<'b list> =
+        traverser f (fun head tail -> cons <!> f head <&> tail) (singleton []) asyncOptions
 
-    let internal sequenceAParallel (asyncOptions: AsyncOption<'a> list) : AsyncOption<'a list> =
-        traverseAParallel id asyncOptions
+    let sequence (asyncOptions: AsyncOption<'a> list) : AsyncOption<'a list> = mapM id asyncOptions
 
-    let sequence (asyncOptions: AsyncOption<'a> list) : AsyncOption<'a list> = sequenceM asyncOptions
+    let sequenceA (asyncOptions: AsyncOption<'a> list) : AsyncOption<'a list> = traverse id asyncOptions
 
-    let parallel' (asyncOptions: AsyncOption<'a> list) : AsyncOption<'a list> =
-        async {
-            let! array = Async.Parallel asyncOptions
-            return Option.sequence (List.ofArray array)
-        }
+    let sequenceAParallel (asyncOptions: AsyncOption<'a> list) : AsyncOption<'a list> = traverseParallel id asyncOptions
 
     let zip (asyncOption1: AsyncOption<'a>) (asyncOption2: AsyncOption<'b>) : Async<('a * 'b) option> =
         (fun a b -> a, b) <!> asyncOption1

diff --git a/src/AsyncResult.fs b/src/AsyncResult.fs
@@ -33,18 +33,6 @@ module AsyncResultOperators =
             | Error error -> Async.singleton (Error error))
             asyncResult
 
-    let inline (>=>) (f: 'a -> Async<Result<'b, 'e>>) (g: 'b -> Async<Result<'c, 'e>>) : 'a -> Async<Result<'c, 'e>> =
-        fun x ->
-            async {
-                let! f' = f x
-
-                let! g' =
-                    match f' with
-                    | Ok ok -> g ok
-                    | Error e -> Async.singleton (Error e)
-
-                return g'
-            }
 
 namespace FSharp.Prelude
 
@@ -93,40 +81,37 @@ module AsyncResult =
     let bimap (f: 'a -> 'b) (g: 'e1 -> 'e2) (asyncResult: AsyncResult<'a, 'e1>) : AsyncResult<'b, 'e2> =
         (map f >> mapError g) asyncResult
 
-    let compose (f: 'a -> AsyncResult<'b, 'e>) (g: 'b -> AsyncResult<'c, 'e>) : 'a -> AsyncResult<'c, 'e> = f >=> g
+    let rec private traverser (f: 'a -> AsyncResult<'b, 'e>) folder state xs =
+        match xs with
+        | [] -> List.rev <!> state
+        | head :: tail ->
+            async {
+                match! folder head state with
+                | Ok _ as this -> return! traverser f folder (Async.singleton this) tail
+                | Error _ as this -> return this
+            }
 
-    let internal traverseM (f: 'a -> AsyncResult<'b, 'e>) (asyncResults: 'a list) : AsyncResult<'b list, 'e> =
-        List.foldBack
-            (fun head tail ->
-                f head
-                >>= (fun head' ->
+    let mapM (f: 'a -> AsyncResult<'b, 'e>) (asyncResults: 'a list) : AsyncResult<'b list, 'e> =
+        let folder head tail =
+            f head
+            >>= fun head' ->
                     tail
-                    >>= (fun tail' -> singleton ((fun h t -> h :: t) head' tail'))))
-            asyncResults
-            (singleton [])
-
-    let internal traverseA (f: 'a -> AsyncResult<'b, 'e>) (asyncResults: 'a list) : AsyncResult<'b list, 'e> =
-        List.foldBack (fun head tail -> (fun h t -> h :: t) <!> f head <*> tail) asyncResults (singleton [])
+                    >>= fun tail' -> singleton <| cons head' tail'
 
-    let internal traverseAParallel (f: 'a -> AsyncResult<'b, 'e>) (asyncResults: 'a list) : AsyncResult<'b list, 'e> =
-        List.foldBack (fun head tail -> (fun h t -> h :: t) <!> f head <&> tail) asyncResults (singleton [])
+        traverser f folder (singleton []) asyncResults
 
-    let internal sequenceM (asyncResults: AsyncResult<'a, 'e> list) : AsyncResult<'a list, 'e> =
-        traverseM id asyncResults
+    let traverse (f: 'a -> AsyncResult<'b, 'e>) (asyncResults: 'a list) : AsyncResult<'b list, 'e> =
+        traverser f (fun head tail -> cons <!> f head <*> tail) (singleton []) asyncResults
 
-    let internal sequenceA (asyncResults: AsyncResult<'a, 'e> list) : AsyncResult<'a list, 'e> =
-        traverseA id asyncResults
+    let traverseParallel (f: 'a -> AsyncResult<'b, 'e>) (asyncResults: 'a list) : AsyncResult<'b list, 'e> =
+        traverser f (fun head tail -> cons <!> f head <&> tail) (singleton []) asyncResults
 
-    let internal sequenceAParallel (asyncResults: AsyncResult<'a, 'e> list) : AsyncResult<'a list, 'e> =
-        traverseAParallel id asyncResults
+    let sequence (asyncResults: AsyncResult<'a, 'e> list) : AsyncResult<'a list, 'e> = mapM id asyncResults
 
-    let sequence (asyncResults: AsyncResult<'a, 'e> list) : AsyncResult<'a list, 'e> = sequenceM asyncResults
+    let sequenceA (asyncResults: AsyncResult<'a, 'e> list) : AsyncResult<'a list, 'e> = traverse id asyncResults
 
-    let parallel' (asyncResults: AsyncResult<'a, 'e> list) : AsyncResult<'a list, 'e> =
-        async {
-            let! array = Async.Parallel asyncResults
-            return Result.sequence (List.ofArray array)
-        }
+    let sequenceAParallel (asyncResults: AsyncResult<'a, 'e> list) : AsyncResult<'a list, 'e> =
+        traverseParallel id asyncResults
 
     let zip (asyncResult1: AsyncResult<'a, 'e>) (asyncResult2: AsyncResult<'b, 'e>) : AsyncResult<'a * 'b, 'e> =
         (fun a b -> a, b) <!> asyncResult1

diff --git a/src/AsyncResultOption.fs b/src/AsyncResultOption.fs
@@ -35,22 +35,6 @@ module AsyncResultOptionOperators =
             | None -> AsyncResult.singleton None)
             asyncResultOption
 
-    let inline (>=>)
-        (f: 'a -> AsyncResult<'b option, 'e>)
-        (g: 'b -> AsyncResult<'c option, 'e>)
-        : 'a -> AsyncResult<'c option, 'e> =
-        fun x ->
-            asyncResult {
-                let! f' = f x
-
-                let! g' =
-                    match f' with
-                    | Some thing -> g thing
-                    | None -> AsyncResult.singleton None
-
-                return g'
-            }
-
     let inline (<|>)
         (asyncOption1: AsyncResult<'a option, 'e>)
         (asyncOption2: AsyncResult<'a option, 'e>)
@@ -120,53 +104,42 @@ module AsyncResultOption =
         : AsyncResultOption<'b, 'e2> =
         (map f >> mapError g) asyncResultOption
 
-    let compose
-        (f: 'a -> AsyncResultOption<'b, 'e>)
-        (g: 'b -> AsyncResultOption<'c, 'e>)
-        : 'a -> AsyncResultOption<'c, 'e> =
-        f >=> g
+    let rec private traverser (f: 'a -> AsyncResultOption<'b, 'e>) folder state xs =
+        match xs with
+        | [] -> List.rev <!> state
+        | head :: tail ->
+            async {
+                match! folder head state with
+                | Ok _ as this -> return! traverser f folder (Async.singleton this) tail
+                | Error _ as this -> return this
+            }
 
-    let internal traverseM
-        (f: 'a -> AsyncResultOption<'b, 'e>)
-        (asyncResultOptions: 'a list)
-        : AsyncResultOption<'b list, 'e> =
-        List.foldBack
-            (fun head tail ->
-                f head
-                >>= (fun head' ->
+    let mapM (f: 'a -> AsyncResultOption<'b, 'e>) (asyncResultOptions: 'a list) : AsyncResultOption<'b list, 'e> =
+        let folder head tail =
+            f head
+            >>= fun head' ->
                     tail
-                    >>= (fun tail' -> singleton ((fun h t -> h :: t) head' tail'))))
-            asyncResultOptions
-            (singleton [])
+                    >>= fun tail' -> singleton <| cons head' tail'
 
-    let internal traverseA
-        (f: 'a -> AsyncResultOption<'b, 'e>)
-        (asyncResultOptions: 'a list)
-        : AsyncResultOption<'b list, 'e> =
-        List.foldBack (fun head tail -> (fun h t -> h :: t) <!> f head <*> tail) asyncResultOptions (singleton [])
+        traverser f folder (singleton []) asyncResultOptions
 
-    let internal traverseAParallel
+    let traverse (f: 'a -> AsyncResultOption<'b, 'e>) (asyncResultOptions: 'a list) : AsyncResultOption<'b list, 'e> =
+        traverser f (fun head tail -> cons <!> f head <*> tail) (singleton []) asyncResultOptions
+
+    let traverseParallel
         (f: 'a -> AsyncResultOption<'b, 'e>)
         (asyncResultOptions: 'a list)
         : AsyncResultOption<'b list, 'e> =
-        List.foldBack (fun head tail -> (fun h t -> h :: t) <!> f head <&> tail) asyncResultOptions (singleton [])
-
-    let internal sequenceM (asyncResultOptions: AsyncResultOption<'a, 'e> list) : AsyncResultOption<'a list, 'e> =
-        traverseM id asyncResultOptions
-
-    let internal sequenceA (asyncResultOptions: AsyncResultOption<'a, 'e> list) : AsyncResultOption<'a list, 'e> =
-        traverseA id asyncResultOptions
-
-    let internal sequenceAParallel
-        (asyncResultOptions: AsyncResultOption<'a, 'e> list)
-        : AsyncResultOption<'a list, 'e> =
-        traverseAParallel id asyncResultOptions
+        traverser f (fun head tail -> cons <!> f head <&> tail) (singleton []) asyncResultOptions
 
     let sequence (asyncResultOptions: AsyncResultOption<'a, 'e> list) : AsyncResultOption<'a list, 'e> =
-        sequenceM asyncResultOptions
+        mapM id asyncResultOptions
+
+    let sequenceA (asyncResultOptions: AsyncResultOption<'a, 'e> list) : AsyncResultOption<'a list, 'e> =
+        traverse id asyncResultOptions
 
-    let parallel' (asyncResultOptions: AsyncResultOption<'a, 'e> list) : AsyncResultOption<'a list, 'e> =
-        sequenceAParallel asyncResultOptions
+    let sequenceAParallel (asyncResultOptions: AsyncResultOption<'a, 'e> list) : AsyncResultOption<'a list, 'e> =
+        traverseParallel id asyncResultOptions
 
     let zip
         (asyncResultOption1: AsyncResultOption<'a, 'e>)

diff --git a/src/FSharp.Prelude.fsproj b/src/FSharp.Prelude.fsproj
@@ -14,6 +14,7 @@
     </PropertyGroup>
 
     <ItemGroup>
+        <Compile Include="Internal.fs" />
         <Compile Include="Option.fs" />
         <Compile Include="Result.fs" />
         <Compile Include="Async.fs" />

diff --git a/src/Internal.fs b/src/Internal.fs
@@ -0,0 +1,4 @@
+[<AutoOpen>]
+module internal Internal
+
+let cons head tail = head :: tail