diff --git a/src/FSharpPlus/Control/Monad.fs b/src/FSharpPlus/Control/Monad.fs index cfbc24936..e6ac44348 100644 --- a/src/FSharpPlus/Control/Monad.fs +++ b/src/FSharpPlus/Control/Monad.fs @@ -20,6 +20,7 @@ type Bind = static member (>>=) (source: seq<'T> , f: 'T -> seq<'U> ) = Seq.bind f source : seq<'U> #if !FABLE_COMPILER static member (>>=) (source: Task<'T> , f: 'T -> Task<'U> ) = source.ContinueWith(fun (x: Task<_>) -> f x.Result).Unwrap () : Task<'U> + static member (>>=) (source: Expr<'T> , f: 'T -> Expr<'U> ) = Expr.bind f source : Expr<'U> static member (>>=) (source , f: 'T -> _ ) = Nullable.bind f source : Nullable<'U> #endif static member (>>=) (source , f: 'T -> _ ) = Option.bind f source : option<'U> @@ -158,7 +159,7 @@ type Delay = static member Delay (_mthd: Default2, x: unit-> 'R -> _ , _ ) = (fun s -> x () s): 'R -> _ static member Delay (_mthd: Delay , x: unit-> _ , _ ) = async.Delay x : Async<'T> static member Delay (_mthd: Delay , x: unit-> Lazy<_> , _ ) = lazy (x().Value) : Lazy<'T> - + static member Delay (_mthd: Delay , x: unit-> Expr<_> , _ ) = Expr.bind x (Return.Invoke ()) : Expr<'T> static member inline Invoke source : 'R = let inline call (mthd: ^M, input: unit -> ^I) = ((^M or ^I) : (static member Delay : _*_*_ -> _) mthd, input, Unchecked.defaultof) diff --git a/src/FSharpPlus/Extensions/Expr.fs b/src/FSharpPlus/Extensions/Expr.fs new file mode 100644 index 000000000..99b3380fa --- /dev/null +++ b/src/FSharpPlus/Extensions/Expr.fs @@ -0,0 +1,44 @@ +namespace FSharpPlus + +#if !FABLE_COMPILER + +/// Additional operations on Quotations.Expr +[] +module Expr = + + open System + open Microsoft.FSharp.Quotations + open Microsoft.FSharp.Quotations.Patterns + open Microsoft.FSharp.Quotations.ExprShape + + let [] private fsNamespace = "Microsoft.FSharp.Core" + + let [] private opSliceName = "SpliceExpression" + let [] private opSliceType = "ExtraTopLevelOperators" + let [] private ubSliceName = "Unbox" + let [] private ubSliceType = "Operators" + + let private fsCoreAs = AppDomain.CurrentDomain.GetAssemblies () |> Seq.find (fun a -> a.GetName().Name = "FSharp.Core") + let private miSplice = fsCoreAs.GetType(fsNamespace + "." + opSliceType).GetMethod opSliceName + let private ubSplice = fsCoreAs.GetType(fsNamespace + "." + ubSliceType).GetMethod ubSliceName + + let bind (f: 'T -> Expr<'U>) (x: Expr<'T>) : Expr<'U> = + Expr.Call (ubSplice.MakeGenericMethod typeof<'U>, + [Expr.Call (miSplice.MakeGenericMethod typeof<'U>, [Expr.Application (Expr.Value f, x)])]) + |> Expr.Cast + + let rec runWithUntyped (eval: Expr -> obj) (exp: Expr) s = + let m = if isNull s then let x = Reflection.MethodInfo.GetCurrentMethod () in x.DeclaringType.GetMethod x.Name else s + let rec subsExpr = function + | Call (None, mi, exprLst) + when (mi.Name, mi.DeclaringType.Name, mi.DeclaringType.Namespace) = (opSliceName, opSliceType, fsNamespace) + -> Expr.Call (m, [Expr.Value eval; subsExpr exprLst.Head; Expr.Value m]) + | ShapeVar var -> Expr.Var var + | ShapeLambda (var, expr) -> Expr.Lambda (var, subsExpr expr) + | ShapeCombination (shpComb, exprLst) -> RebuildShapeCombination (shpComb, List.map subsExpr exprLst) + eval (subsExpr exp) + + /// Executes quoted expression, given a quotation evaluator function. + let run (eval: Expr -> obj) (exp: Expr<'T>) : 'T = runWithUntyped eval exp.Raw null :?> 'T + +#endif \ No newline at end of file diff --git a/src/FSharpPlus/FSharpPlus.fsproj b/src/FSharpPlus/FSharpPlus.fsproj index 8c18fba5f..f6c84522d 100644 --- a/src/FSharpPlus/FSharpPlus.fsproj +++ b/src/FSharpPlus/FSharpPlus.fsproj @@ -47,6 +47,7 @@ + diff --git a/tests/FSharpPlus.Tests/Expr.fs b/tests/FSharpPlus.Tests/Expr.fs new file mode 100644 index 000000000..9c327d949 --- /dev/null +++ b/tests/FSharpPlus.Tests/Expr.fs @@ -0,0 +1,98 @@ +namespace FSharpPlus.Tests + +open System +open NUnit.Framework +open FSharpPlus +open FSharpPlus.Tests.Helpers + +module Expr = + + let quotseval x = +#if NETSTANDARD + FSharp.Quotations.Evaluator.QuotationEvaluator.EvaluateUntyped x +#else + Swensen.Unquote.Operators.evalRaw x +#endif + let unquote x = Swensen.Unquote.Operators.evalRaw x + let powerpack x = Microsoft.FSharp.Linq.QuotationEvaluator.EvaluateUntyped x + + + + let ``Simple quotation combination`` evaluator = + let one = <@ 1 @> + let add10AndToString x = + let a = string (x + 10) + <@ a @> + + let expr = one >>= add10AndToString + let res = Expr.run evaluator expr + + areEqual "11" res + + let [] ``Simple quotation combination [QuotationEvaluator]`` () = ``Simple quotation combination`` quotseval + let [] ``Simple quotation combination [Unquote]`` () = ``Simple quotation combination`` unquote + let [] ``Simple quotation combination [PowerPack]`` () = ``Simple quotation combination`` powerpack + + + let ``2-layers quotation combination`` evaluator = + let expr = + <@ 4 + 5 @> + >>= (fun x -> + let a = x + 10 + <@ (a, a*a) @> + >>= fun (x, y) -> + <@ ([x + y], x, y, [|x; y|]) @>) + let res = Expr.run evaluator expr + + areEqual ([380], 19, 361, [|19; 361|]) res + + let [] ``2-layers quotation combination [QuotationEvaluator]`` () = ``2-layers quotation combination`` quotseval + let [] ``2-layers quotation combination [Unquote]`` () = ``2-layers quotation combination`` unquote + let [] ``2-layers quotation combination [PowerPack]`` () = ``2-layers quotation combination`` powerpack + + + let ``2-layers quot comb associative`` evaluator = + let expr = + (<@ 4 + 5 @> + >>= fun x -> + let a = x + 10 + <@ (a, a*a) @>) + >>= fun (x, y) -> + <@ ([x + y], x, y, [|x; y|]) @> + let res = Expr.run evaluator expr + + areEqual ([380], 19, 361, [|19; 361|]) res + + let [] ``2-layers quot comb associative [QuotationEvaluator]`` () = ``2-layers quot comb associative`` quotseval + let [] ``2-layers quot comb associative [Unquote]`` () = ``2-layers quot comb associative`` unquote + let [] ``2-layers quot comb associative [PowerPack]`` () = ``2-layers quot comb associative`` powerpack + + + let ``simple CE same type`` evaluator = + let expr = monad { + let! x = <@ 1 @> + let! y = <@ 2 @> + return! <@ x + y @> + } + let res = Expr.run evaluator expr + + areEqual 3 res + + let [] ``simple CE same type [QuotationEvaluator]`` () = ``simple CE same type`` quotseval + let [] ``simple CE same type [Unquote]`` () = ``simple CE same type`` unquote + let [] ``simple CE same type [PowerPack]`` () = ``simple CE same type`` powerpack + + + let ``simple CE different types`` evaluator = + let expr = monad { + let! x = <@ 1 @> + let! y = <@ "2" @> + return! <@ string x + y @> + } + let res = Expr.run evaluator expr + + areEqual "12" res + + let [] ``simple CE different types [QuotationEvaluator]`` () = ``simple CE different types`` quotseval + let [] ``simple CE different types [Unquote]`` () = ``simple CE different types`` unquote + let [] ``simple CE different types [PowerPack]`` () = ``simple CE different types`` powerpack \ No newline at end of file diff --git a/tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj b/tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj index 68a2efc4f..632c8cf31 100644 --- a/tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj +++ b/tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj @@ -15,6 +15,7 @@ + @@ -32,7 +33,9 @@ + + @@ -40,4 +43,9 @@ + + + 2.1.0 + +