Merge pull request #7 from TypedUseCase/feature/parse-domain-async

Parse domain asynchronously

Author: MortalFlesh

CHANGELOG.md

@@ -2,6 +2,10 @@
 
 <!-- There is always Unreleased section on the top. Subsections (Add, Changed, Fix, Removed) should be Add as needed. -->
 ## Unreleased
+- [**BC**] Change function `Parser.parse` to return Async Result
+- [**BC**] Change `Resolver.resolve` function to return a `ResolveError` on error
+- Add `Resolver.resolveAsync` function
+- [_Internal_] Fix `asyncResult` computation expression
 
 ## 2.1.0 - 2021-08-11
 - Update dependencies

src/Domain/Parser.fs

@@ -5,18 +5,32 @@ open FSharp.Compiler.Text
 
 type ParsedDomain = ParsedDomain of FSharpCheckProjectResults
 
+type ParseError =
+    | ProjectOptionsNotAvailable of exn
+    | ParseAndCheckProjectFailed of exn
+    | ParseError of exn
+
+[<RequireQualifiedAccess>]
+module ParseError =
+    let format = function
+        | ProjectOptionsNotAvailable e -> sprintf "[Domain Parser][Parse error]: Project options not available due to:\n%A" e
+        | ParseAndCheckProjectFailed e -> sprintf "[Domain Parser][Parse error]: Project parsing and checking failed on:\n%A" e
+        | ParseError e -> sprintf "[Domain Parser][Parse error]: Parsing failed on:\n%A" e
+
 [<RequireQualifiedAccess>]
 module Parser =
     open System
     open System.IO
+    open ErrorHandling
 
-    let private parseAndCheck (output: MF.ConsoleApplication.Output) (checker: FSharpChecker) (file, input) =
+    let private parseAndCheck (output: MF.ConsoleApplication.Output) (checker: FSharpChecker) (file, input) = asyncResult {
         if output.IsVerbose() then output.Title "ParseAndCheck"
 
         if output.IsVeryVerbose() then output.Section "GetProjectOptionsFromScript"
-        let projOptions, errors =
+
+        let! projOptions, errors =
             checker.GetProjectOptionsFromScript(file, SourceText.ofString input)
-            |> Async.RunSynchronously
+            |> AsyncResult.ofAsyncCatch ProjectOptionsNotAvailable
 
         if output.IsVeryVerbose() then output.Message "Ok"
         if output.IsDebug() then output.Message <| sprintf "ProjOptions:\n%A" projOptions
@@ -54,17 +68,24 @@ module Parser =
         if output.IsVeryVerbose() then output.Message "Ok"
 
         if output.IsVeryVerbose() then output.Section "ParseAndCheckProject"
-        checker.ParseAndCheckProject (fprojOptions)
-        |> Async.RunSynchronously
-        |> tee (fun parseFileResults ->
-            if output.IsVeryVerbose() then output.Message "Ok"
-
-            if output.IsDebug() then output.Options "Result:" [
-                ["DependencyFiles"; parseFileResults.DependencyFiles |> sprintf "%A"]
-                ["Errors"; parseFileResults.HasCriticalErrors |> sprintf "%A"]
-                ["ProjectContext"; parseFileResults.ProjectContext |> sprintf "%A"]
-            ]
-        )
+
+        let! checkProjectResults =
+            fprojOptions
+            |> checker.ParseAndCheckProject
+            |> AsyncResult.ofAsyncCatch ParseAndCheckProjectFailed
+
+        return
+            checkProjectResults
+            |> tee (fun parseFileResults ->
+                if output.IsVeryVerbose() then output.Message "Ok"
+
+                if output.IsDebug() then output.Options "Result:" [
+                    ["DependencyFiles"; parseFileResults.DependencyFiles |> sprintf "%A"]
+                    ["Errors"; parseFileResults.HasCriticalErrors |> sprintf "%A"]
+                    ["ProjectContext"; parseFileResults.ProjectContext |> sprintf "%A"]
+                ]
+            )
+    }
 
     let parse (output: MF.ConsoleApplication.Output) file =
         let checker = FSharpChecker.Create()    // to allow implementation details add: keepAssemblyContents=true
@@ -73,4 +94,14 @@ module Parser =
 
         (file, File.ReadAllText file)
         |> parseAndCheck output checker
-        |> ParsedDomain
+        |> AsyncResult.map ParsedDomain
+
+    let parseSequentualy output files =
+        files
+        |> List.map (parse output)
+        |> AsyncResult.ofSequentialAsyncResults ParseError
+
+    let parseParallely output files =
+        files
+        |> List.map (parse output)
+        |> AsyncResult.ofParallelAsyncResults ParseError

src/Domain/Resolver.fs

@@ -2,6 +2,20 @@ namespace Tuc.Domain
 
 open FSharp.Compiler.Symbols
 
+[<RequireQualifiedAccess>]
+type ResolveError =
+    | UnresolvedTypes of TypeName list
+
+[<RequireQualifiedAccess>]
+type AsyncResolveError =
+    | ParseError of ParseError list
+    | UnresolvedTypes of TypeName list
+
+[<RequireQualifiedAccess>]
+module internal AsyncResolveError =
+    let ofResolveError = function
+        | ResolveError.UnresolvedTypes types -> AsyncResolveError.UnresolvedTypes types
+
 [<RequireQualifiedAccess>]
 module Resolver =
     open Option.Operators
@@ -297,7 +311,7 @@ module Resolver =
                     :: resolvedTypes
                     |> output.Options (sprintf "Resolved (or scalar) types [%d]:" (resolvedTypes |> List.length))
 
-    let resolve output (parsedDomains: ParsedDomain list): Result<ResolvedType list, _> =
+    let resolve output (parsedDomains: ParsedDomain list): Result<ResolvedType list, ResolveError> =
         let emptyResolvedTypes: ResolvedTypes = Map.empty
 
         // resolve all scalar types in advance
@@ -331,4 +345,36 @@ module Resolver =
         | unresolvedTypes ->
             unresolvedTypes
             |> List.map ResolvedType.name
+            |> ResolveError.UnresolvedTypes
             |> Error
+
+    let resolveOne output (parsedDomain: ParsedDomain): Result<ResolvedType list, ResolveError> =
+        [ parsedDomain ]
+        |> resolve output
+
+    open ErrorHandling
+    open ErrorHandling.AsyncResult.Operators
+
+    let resolveOneAsync output (parseDomain: AsyncResult<ParsedDomain, ParseError>): AsyncResult<ResolvedType list, AsyncResolveError> =
+        asyncResult {
+            let! parsedDomain = parseDomain <@> (List.singleton >> AsyncResolveError.ParseError)
+
+            let! resolved =
+                parsedDomain
+                |> resolveOne output
+                |> AsyncResult.ofResult <@> AsyncResolveError.ofResolveError
+
+            return resolved
+        }
+
+    let resolveAsync output (parseDomains: AsyncResult<ParsedDomain list, ParseError list>): AsyncResult<ResolvedType list, AsyncResolveError> =
+        asyncResult {
+            let! parsedDomains = parseDomains <@> AsyncResolveError.ParseError
+
+            let! resolved =
+                parsedDomains
+                |> resolve output
+                |> AsyncResult.ofResult <@> AsyncResolveError.ofResolveError
+
+            return resolved
+        }

src/ErrorHandling/Result.fs

@@ -373,6 +373,46 @@ module AsyncResult =
     let ofTaskCatch f x : AsyncResult<_, _> =
         x |> ofTask |> catch f
 
+     /// Run asyncResults in Parallel, handles the errors and concats results
+    let ofParallelAsyncResults<'Success, 'Error> (f: exn -> 'Error) (results: AsyncResult<'Success, 'Error> list): AsyncResult<'Success list, 'Error list> =
+        results
+        |> List.map (mapError List.singleton)
+        |> Async.Parallel
+        |> ofAsyncCatch (f >> List.singleton)
+        |> bind (
+            Seq.toList
+            >> Validation.ofResults
+            >> Result.mapError List.concat
+            >> ofResult
+        )
+
+    /// Run asyncs in Parallel, handles the errors and concats results
+    let ofParallelAsyncs<'Success, 'Error> (f: exn -> 'Error) (asyncs: Async<'Success> list): AsyncResult<'Success list, 'Error list> =
+        asyncs
+        |> Async.Parallel
+        |> ofAsyncCatch (f >> List.singleton)
+        |> map Seq.toList
+
+    /// Run asyncResults in Parallel, handles the errors and concats results
+    let ofSequentialAsyncResults<'Success, 'Error> (f: exn -> 'Error) (results: AsyncResult<'Success, 'Error> list): AsyncResult<'Success list, 'Error list> =
+        results
+        |> List.map (mapError List.singleton)
+        |> Async.Sequential
+        |> ofAsyncCatch (f >> List.singleton)
+        |> bind (
+            Seq.toList
+            >> Validation.ofResults
+            >> Result.mapError List.concat
+            >> ofResult
+        )
+
+    /// Run asyncs in Parallel, handles the errors and concats results
+    let ofSequentialAsyncs<'Success, 'Error> (f: exn -> 'Error) (asyncs: Async<'Success> list): AsyncResult<'Success list, 'Error list> =
+        asyncs
+        |> Async.Sequential
+        |> ofAsyncCatch (f >> List.singleton)
+        |> map Seq.toList
+
     //-----------------------------------
     // Utilities lifted from Async
 
@@ -405,44 +445,43 @@ module AsyncResult =
 /// The `asyncResult` computation expression is available globally without qualification
 [<AutoOpen>]
 module AsyncResultComputationExpression =
+    open System
 
     type AsyncResultBuilder() =
-        member __.Return(x) = AsyncResult.retn x
-        member __.Bind(x, f) = AsyncResult.bind f x
+        member __.Return (value: 'Success): AsyncResult<'Success, 'Error> =
+            async.Return <| result.Return value
 
-        member __.ReturnFrom(x) = x
-        member this.Zero() = this.Return ()
+        member __.ReturnFrom(asyncResult: AsyncResult<'Success, 'Error>): AsyncResult<'Success, 'Error> =
+            asyncResult
 
-        member __.Delay(f) = f
-        member __.Run(f) = f()
+        member __.Zero (): AsyncResult<unit, 'Error> =
+            async.Return <| result.Zero ()
 
-        member this.While(guard, body) =
-            if not (guard())
-            then this.Zero()
-            else this.Bind( body(), fun () ->
-                this.While(guard, body))
+        member __.Bind (asyncResult: AsyncResult<'SuccessA, 'Error>, (f: 'SuccessA -> AsyncResult<'SuccessB, 'Error>)): AsyncResult<'SuccessB, 'Error> =
+            asyncResult |> AsyncResult.bind f
 
-        member this.TryWith(body, handler) =
-            try this.ReturnFrom(body())
-            with e -> handler e
+        member __.Delay (generator: unit -> AsyncResult<'Success, 'Error>): AsyncResult<'Success, 'Error> =
+            async.Delay generator
 
-        member this.TryFinally(body, compensation) =
-            try this.ReturnFrom(body())
-            finally compensation()
+        member this.Combine (computation1: AsyncResult<unit, 'Error>, computation2: AsyncResult<'U, 'Error>): AsyncResult<'U, 'Error> =
+            this.Bind(computation1, fun () -> computation2)
 
-        member this.Using(disposable:#System.IDisposable, body) =
-            let body' = fun () -> body disposable
-            this.TryFinally(body', fun () ->
-                match disposable with
-                    | null -> ()
-                    | disp -> disp.Dispose())
+        member __.TryWith (computation: AsyncResult<'Success, 'Error>, handler: exn -> AsyncResult<'Success, 'Error>): AsyncResult<'Success, 'Error> =
+            async.TryWith(computation, handler)
 
-        member this.For(sequence:seq<_>, body) =
-            this.Using(sequence.GetEnumerator(),fun enum ->
-                this.While(enum.MoveNext,
-                    this.Delay(fun () -> body enum.Current)))
+        member __.TryFinally (computation: AsyncResult<'Success, 'Error>, compensation: unit -> unit): AsyncResult<'Success, 'Error> =
+            async.TryFinally(computation, compensation)
 
-        member this.Combine (a,b) =
-            this.Bind(a, fun () -> b())
+        member __.Using (resource: 'SuccessA when 'SuccessA :> IDisposable, binder: 'SuccessA -> AsyncResult<'SuccessB, 'Error>): AsyncResult<'SuccessB, 'Error> =
+            async.Using(resource, binder)
+
+        member this.While (guard: unit -> bool, computation: AsyncResult<unit, 'Error>): AsyncResult<unit, 'Error> =
+            if not <| guard () then this.Zero ()
+            else this.Bind(computation, fun () -> this.While (guard, computation))
+
+        member this.For (sequence: #seq<'Success>, binder: 'Success -> AsyncResult<unit, 'Error>): AsyncResult<unit, 'Error> =
+            this.Using(sequence.GetEnumerator (), fun enum ->
+                this.While(enum.MoveNext,
+                    this.Delay(fun () -> binder enum.Current)))
 
     let asyncResult = AsyncResultBuilder()

tests/Domain/ResolverTest.fs

@@ -2,6 +2,7 @@ module Tuc.Domain.Test.Parser
 
 open Expecto
 open System.IO
+open ErrorHandling
 
 let (</>) a b = Path.Combine(a, b)
 
@@ -41,7 +42,7 @@ module Domain =
     type Case = {
         Description: string
         Domain: string
-        Expected: Result<ResolvedType list, TypeName list>
+        Expected: Result<ResolvedType list, AsyncResolveError>
     }
 
     let case description domain expected =
@@ -263,8 +264,8 @@ module Domain =
         let resolvedDomain =
             domain
             |> Parser.parse output
-            |> List.singleton
-            |> Resolver.resolve output
+            |> Resolver.resolveOneAsync output
+            |> Async.RunSynchronously
 
         match expected, resolvedDomain with
         | Ok expected, Ok actual -> Expect.equal (actual |> List.sort) (expected |> List.sort) description