Quotation Monad

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<Delay>)

src/FSharpPlus/Extensions/Expr.fs

@@ -0,0 +1,44 @@
+namespace FSharpPlus
+
+#if !FABLE_COMPILER
+
+/// Additional operations on Quotations.Expr
+[<RequireQualifiedAccess>]
+module Expr =
+
+    open System
+    open Microsoft.FSharp.Quotations
+    open Microsoft.FSharp.Quotations.Patterns
+    open Microsoft.FSharp.Quotations.ExprShape
+
+    let [<Literal>] private fsNamespace = "Microsoft.FSharp.Core"
+
+    let [<Literal>] private opSliceName = "SpliceExpression"
+    let [<Literal>] private opSliceType = "ExtraTopLevelOperators"
+    let [<Literal>] private ubSliceName = "Unbox"
+    let [<Literal>] 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

src/FSharpPlus/FSharpPlus.fsproj

@@ -47,6 +47,7 @@
     <Compile Include="Extensions/Task.fs" />
     <Compile Include="Extensions/Async.fs" />
     <Compile Include="Extensions/Extensions.fs" />
+    <Compile Include="Extensions/Expr.fs" />
     <Compile Include="Extensions/Tuple.fs" />
     <Compile Include="TypeLevel/TypeLevelOperators.fs" />
     <Compile Include="TypeLevel/TypeBool.fs" />

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 [<Test>] ``Simple quotation combination [QuotationEvaluator]`` () = ``Simple quotation combination`` quotseval
+    let [<Test>] ``Simple quotation combination [Unquote]``            () = ``Simple quotation combination`` unquote
+    let [<Test>] ``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 [<Test>] ``2-layers quotation combination [QuotationEvaluator]`` () = ``2-layers quotation combination`` quotseval
+    let [<Test>] ``2-layers quotation combination [Unquote]``            () = ``2-layers quotation combination`` unquote
+    let [<Test>] ``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 [<Test>] ``2-layers quot comb associative [QuotationEvaluator]`` () = ``2-layers quot comb associative`` quotseval
+    let [<Test>] ``2-layers quot comb associative [Unquote]``            () = ``2-layers quot comb associative`` unquote
+    let [<Test>] ``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 [<Test>] ``simple CE same type [QuotationEvaluator]`` () = ``simple CE same type`` quotseval
+    let [<Test>] ``simple CE same type [Unquote]``            () = ``simple CE same type`` unquote
+    let [<Test>] ``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 [<Test>] ``simple CE different types [QuotationEvaluator]`` () = ``simple CE different types`` quotseval
+    let [<Test>] ``simple CE different types [Unquote]``            () = ``simple CE different types`` unquote
+    let [<Test>] ``simple CE different types [PowerPack]``          () = ``simple CE different types`` powerpack

tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj

@@ -15,6 +15,7 @@
     <Compile Include="General.fs" />
     <Compile Include="Validations.fs" />
     <Compile Include="Free.fs" />
+    <Compile Include="Expr.fs" />
     <Compile Include="ComputationExpressions.fs" />
     <Compile Include="Lens.fs" />
     <Compile Include="Extensions.fs" />
@@ -32,12 +33,19 @@
     <ProjectReference Include="..\CSharpLib\CSharpLib.csproj" />
   </ItemGroup>
   <ItemGroup>
+    <PackageReference Include="FSPowerPack.Linq.Community" Version="3.0.0" />
     <PackageReference Include="System.Runtime" Version="4.3.1" />
+    <PackageReference Include="Unquote" Version="5.0.0" />
     <PackageReference Update="FSharp.Core" Version="4.6.2" />
     <PackageReference Include="MathNet.Numerics.FSharp" Version="4.8.1" />
     <PackageReference Include="NUnit" Version="3.11.0" />
     <PackageReference Include="FsCheck" Version="2.14" />
     <PackageReference Include="NUnit3TestAdapter" Version="3.11.0" />
     <PackageReference Include="Microsoft.NET.Test.Sdk" Version="15.9.0" />
   </ItemGroup>
+  <ItemGroup Condition="'$(TargetFramework)' == 'netcoreapp3.0'">
+    <PackageReference Include="FSharp.Quotations.Evaluator">
+      <Version>2.1.0</Version>
+    </PackageReference>
+  </ItemGroup>
 </Project>