1 people like it.

Staged Monoidal Folds

Staged Monoidal Folds based on https://github.com/Gabriel439/slides/blob/master/munihac/foldmap.md

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
66: 
67: 
68: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
// Staged Monoidal Folds based on https://github.com/Gabriel439/slides/blob/master/munihac/foldmap.md

#r "packages/FSharp.Compiler.Service.1.3.1.0/lib/net45/FSharp.Compiler.Service.dll"
#r "packages/QuotationCompiler.0.0.7-alpha/lib/net45/QuotationCompiler.dll"

open System
open QuotationCompiler
open Microsoft.FSharp.Quotations

// helper functions
let counter = ref 0
let rec generateVars (types : Type list) : Var list = 
    match types with 
    | [] -> []
    | t :: ts -> 
        incr counter
        let var = new Var(sprintf "__paramTemp_%d__" !counter, t)
        var :: generateVars ts

// <@ fun x -> (% <@ x @> ) @> ~ lambda (fun x -> x)
let lambda (f : Expr<'T> -> Expr<'R>) : Expr<'T -> 'R> =
    let [var] = generateVars [typeof<'T>]
    Expr.Cast<_>(Expr.Lambda(var,  f (Expr.Cast<_>(Expr.Var var))))


// <@ fun x y -> (% <@ x @> ... <@ y @> ) @> ~ lambda (fun x y -> x ... y )
let lambda2 (f : Expr<'T> -> Expr<'S> -> Expr<'R>) : Expr<'T -> 'S -> 'R> =
    let [var; var'] = generateVars [typeof<'T>; typeof<'S>]
    Expr.Cast<_>(Expr.Lambda(var, Expr.Lambda(var',  f (Expr.Cast<_>(Expr.Var var)) (Expr.Cast<_>(Expr.Var var')))))


// data Fold i o = forall m . Monoid m => Fold (i -> m) (m -> o)
type Fold<'I, 'O> = 
    abstract member Invoke<'R> : FoldUnPack<'I, 'O, 'R> -> Expr<'R>

and FoldUnPack<'I, 'O, 'R> = 
    abstract member Invoke<'M> : Expr<'M> -> 
                                 (Expr<'M> -> Expr<'M> -> Expr<'M>) ->  
                                 (Expr<'I> -> Expr<'M>) ->
                                 (Expr<'M> -> Expr<'O>) -> Expr<'R>

and FoldCons<'M, 'I, 'O>(zero : Expr<'M>, plus : Expr<'M> -> Expr<'M> -> Expr<'M>, 
                         input : Expr<'I> -> Expr<'M>, output : Expr<'M> -> Expr<'O>) =
    interface Fold<'I, 'O> with
        member self.Invoke<'R> (unPack : FoldUnPack<'I, 'O, 'R>) : Expr<'R> = 
            unPack.Invoke<'M> zero plus input output


// combinators
let fold : Fold<'I, 'O> -> Expr<'I []> -> Expr<'O> = 
    fun mfold source ->
        mfold.Invoke<'O> 
            { new FoldUnPack<'I, 'O, 'O> with
                member self.Invoke<'M> (zero : Expr<'M>) plus input output =                      
                    <@  let mutable acc = %zero
                        for i = 0 to (%source).Length - 1 do
                            let current = (%source).[i]
                            let value = (% lambda (fun v -> input v)) current
                            acc <- (% lambda2 (fun acc v -> plus acc v)) acc value
                            ()
                        (% lambda (fun v -> output v)) acc @> }

let compile (f : Expr<'T> -> Expr<'R>) : 'T -> 'R = QuotationCompiler.ToFunc(lambda f) ()

// Examples
let sum : Fold<int, int> = 
    new FoldCons<int, int, int>(<@ 0 @>, (fun x y -> <@ %x + %y @>), id, id) :> _

let all : (Expr<'I> -> Expr<bool>) -> Fold<'I, bool> = fun p ->
    new FoldCons<bool, 'I, bool>(<@ true @>, (fun x y -> <@ %x && %y @>), (fun v -> p v), id) :> _

let any : (Expr<'I> -> Expr<bool>) -> Fold<'I, bool> = fun p ->
    new FoldCons<bool, 'I, bool>(<@ false @>, (fun x y -> <@ %x || %y @>), (fun v -> p v), id) :> _

let sumf = compile (fold sum)
sumf [|1; 2; 3|] // 6

let allf = compile (fold (all (fun v -> <@ %v % 2 = 0 @>)))
allf [|2; 4|] // true
allf [|1; 2; 4|] // false
namespace System
namespace QuotationCompiler
namespace Microsoft
namespace Microsoft.FSharp
namespace Microsoft.FSharp.Quotations
val counter : int ref

Full name: Script.counter
Multiple items
val ref : value:'T -> 'T ref

Full name: Microsoft.FSharp.Core.Operators.ref

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>
val generateVars : types:Type list -> Var list

Full name: Script.generateVars
val types : Type list
type Type =
  inherit MemberInfo
  member Assembly : Assembly
  member AssemblyQualifiedName : string
  member Attributes : TypeAttributes
  member BaseType : Type
  member ContainsGenericParameters : bool
  member DeclaringMethod : MethodBase
  member DeclaringType : Type
  member Equals : o:obj -> bool + 1 overload
  member FindInterfaces : filter:TypeFilter * filterCriteria:obj -> Type[]
  member FindMembers : memberType:MemberTypes * bindingAttr:BindingFlags * filter:MemberFilter * filterCriteria:obj -> MemberInfo[]
  ...

Full name: System.Type
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
Multiple items
type Var =
  interface IComparable
  new : name:string * typ:Type * ?isMutable:bool -> Var
  member IsMutable : bool
  member Name : string
  member Type : Type
  static member Global : name:string * typ:Type -> Var

Full name: Microsoft.FSharp.Quotations.Var

--------------------
new : name:string * typ:Type * ?isMutable:bool -> Var
val t : Type
val ts : Type list
val incr : cell:int ref -> unit

Full name: Microsoft.FSharp.Core.Operators.incr
val var : Var
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
val lambda : f:(Expr<'T> -> Expr<'R>) -> Expr<('T -> 'R)>

Full name: Script.lambda
val f : (Expr<'T> -> Expr<'R>)
Multiple items
type Expr =
  override Equals : obj:obj -> bool
  member GetFreeVars : unit -> seq<Var>
  member Substitute : substitution:(Var -> Expr option) -> Expr
  member ToString : full:bool -> string
  member CustomAttributes : Expr list
  member Type : Type
  static member AddressOf : target:Expr -> Expr
  static member AddressSet : target:Expr * value:Expr -> Expr
  static member Application : functionExpr:Expr * argument:Expr -> Expr
  static member Applications : functionExpr:Expr * arguments:Expr list list -> Expr
  ...

Full name: Microsoft.FSharp.Quotations.Expr

--------------------
type Expr<'T> =
  inherit Expr
  member Raw : Expr

Full name: Microsoft.FSharp.Quotations.Expr<_>
val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof
static member Expr.Cast : source:Expr -> Expr<'T>
static member Expr.Lambda : parameter:Var * body:Expr -> Expr
static member Expr.Var : variable:Var -> Expr
val lambda2 : f:(Expr<'T> -> Expr<'S> -> Expr<'R>) -> Expr<('T -> 'S -> 'R)>

Full name: Script.lambda2
val f : (Expr<'T> -> Expr<'S> -> Expr<'R>)
val var' : Var
type Fold<'I,'O> =
  interface
    abstract member Invoke : FoldUnPack<'I,'O,'R> -> Expr<'R>
  end

Full name: Script.Fold<_,_>
abstract member Fold.Invoke : FoldUnPack<'I,'O,'R> -> Expr<'R>

Full name: Script.Fold`2.Invoke
type FoldUnPack<'I,'O,'R> =
  interface
    abstract member Invoke : Expr<'M> -> (Expr<'M> -> Expr<'M> -> Expr<'M>) -> (Expr<'I> -> Expr<'M>) -> (Expr<'M> -> Expr<'O>) -> Expr<'R>
  end

Full name: Script.FoldUnPack<_,_,_>
abstract member FoldUnPack.Invoke : Expr<'M> -> (Expr<'M> -> Expr<'M> -> Expr<'M>) -> (Expr<'I> -> Expr<'M>) -> (Expr<'M> -> Expr<'O>) -> Expr<'R>

Full name: Script.FoldUnPack`3.Invoke
Multiple items
type FoldCons<'M,'I,'O> =
  interface Fold<'I,'O>
  new : zero:Expr<'M> * plus:(Expr<'M> -> Expr<'M> -> Expr<'M>) * input:(Expr<'I> -> Expr<'M>) * output:(Expr<'M> -> Expr<'O>) -> FoldCons<'M,'I,'O>

Full name: Script.FoldCons<_,_,_>

--------------------
new : zero:Expr<'M> * plus:(Expr<'M> -> Expr<'M> -> Expr<'M>) * input:(Expr<'I> -> Expr<'M>) * output:(Expr<'M> -> Expr<'O>) -> FoldCons<'M,'I,'O>
val zero : Expr<'M>
val plus : (Expr<'M> -> Expr<'M> -> Expr<'M>)
val input : (Expr<'I> -> Expr<'M>)
val output : (Expr<'M> -> Expr<'O>)
val self : FoldCons<'M,'I,'O>
override FoldCons.Invoke : unPack:FoldUnPack<'I,'O,'R> -> Expr<'R>

Full name: Script.FoldCons`3.Invoke
val unPack : FoldUnPack<'I,'O,'R>
abstract member FoldUnPack.Invoke : Expr<'M> -> (Expr<'M> -> Expr<'M> -> Expr<'M>) -> (Expr<'I> -> Expr<'M>) -> (Expr<'M> -> Expr<'O>) -> Expr<'R>
val fold : mfold:Fold<'I,'O> -> source:Expr<'I []> -> Expr<'O>

Full name: Script.fold
val mfold : Fold<'I,'O>
val source : Expr<'I []>
abstract member Fold.Invoke : FoldUnPack<'I,'O,'R> -> Expr<'R>
val self : FoldUnPack<'I,'O,'O>
val mutable acc : 'M
val i : int
val current : 'I
val value : 'M
val v : Expr<'I>
val acc : Expr<'M>
val v : Expr<'M>
val compile : f:(Expr<'T> -> Expr<'R>) -> ('T -> 'R)

Full name: Script.compile
Multiple items
namespace QuotationCompiler

--------------------
type QuotationCompiler =
  private new : unit -> QuotationCompiler
  static member Eval : expr:Expr<'T> * ?useCache:bool -> 'T
  static member ToAssembly : expr:Expr * ?targetDirectory:string * ?assemblyName:string * ?compiledModuleName:string * ?compiledFunctionName:string -> string
  static member ToDynamicAssembly : expr:Expr * ?assemblyName:string -> MethodInfo
  static member ToFunc : expr:Expr<'T> * ?useCache:bool -> (unit -> 'T)

Full name: QuotationCompiler.QuotationCompiler
static member QuotationCompiler.ToFunc : expr:Expr<'T> * ?useCache:bool -> (unit -> 'T)
val sum : Fold<int,int>

Full name: Script.sum
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
val x : Expr<int>
val y : Expr<int>
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val all : p:(Expr<'I> -> Expr<bool>) -> Fold<'I,bool>

Full name: Script.all
type bool = Boolean

Full name: Microsoft.FSharp.Core.bool
val p : (Expr<'I> -> Expr<bool>)
val x : Expr<bool>
val y : Expr<bool>
val any : p:(Expr<'I> -> Expr<bool>) -> Fold<'I,bool>

Full name: Script.any
val sumf : (int [] -> int)

Full name: Script.sumf
val allf : (int [] -> bool)

Full name: Script.allf
val v : Expr<int>
Raw view Test code New version

More information

Link:http://fssnip.net/7Rj
Posted:7 years ago
Author:Nick Palladinos
Tags: staging , folds