0 people like it.

Staged Ziria Streams

Staged Ziria Streams, based on https://github.com/dimitriv/ziria-sem/blob/master/Haskell/ZirBasic.hs.

  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: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
// Staged Ziria Streams, based on https://github.com/dimitriv/ziria-sem/blob/master/Haskell/ZirBasic.hs

#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

open System
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))))

// Basic type
type Zir<'I, 'O, 'V> =
    | Yield of Zir<'I, 'O, 'V> * Expr<'O>
    | Done of Expr<'V>
    | NeedInput of (Expr<'I> -> Zir<'I, 'O, 'V>)

// helper functions
let emit : Expr<'O> -> Zir<'I, 'O, unit> = 
    fun o -> Yield (Done <@ () @>, o)

let take : Zir<'I, 'O, 'I> = 
    NeedInput Done

let return' : Expr<'V> -> Zir<'I, 'O, 'V> =
    Done 

let rec bind : Zir<'I, 'O, 'V> -> (Expr<'V> -> Zir<'I, 'O, 'W>) -> Zir<'I, 'O, 'W> =
    fun z f ->
        match z with
        | Done v -> f v
        | Yield (z', o) -> Yield (bind z' f, o)
        | NeedInput g -> NeedInput (fun i -> bind (g i) f)

let (>>>) : Zir<'I, 'M, 'V> -> Zir<'M, 'O, 'V> -> Zir<'I, 'O, 'V> =
    fun z1 z2 ->
        let rec go2 : Zir<'I, 'M, 'V> -> Zir<'M, 'O, 'V> -> Zir<'I, 'O, 'V> =
            fun z1 z2 -> 
                match z2 with
                | Done v -> Done v
                | Yield (z2', o) -> Yield (go2 z1 z2', o)
                | NeedInput g -> go1 g z1
        and go1 : (Expr<'M> -> Zir<'M, 'O, 'V>) -> Zir<'I, 'M, 'V> -> Zir<'I, 'O, 'V> =
            fun g z -> 
                match z with
                | Done v -> Done v
                | Yield (z1', o) -> go2 z1' (g o)
                | NeedInput g' -> NeedInput (go1 g << g')
        go2 z1 z2

// Builder type
type ZirBuilder() =
    member self.Return (v : Expr<'V>) = return' v
    member self.Bind(z : Zir<'I, 'O, 'V>, f : Expr<'V> -> Zir<'I, 'O, 'W>) =
        bind z f

let zir = new ZirBuilder()

// example
let example1 : Zir<int, string, unit> = 
    zir {
        let! x = take
        let! _ =  emit <@ string (%x + 1) @>
        let! _ =  emit <@ string (%x + 2) @>
        return <@ () @>
    }

let example2 : Zir<string, int, unit> = 
    zir {
        let! x = take
        let! y = take
        let! _ = emit <@ (System.Int32.Parse %x) + (System.Int32.Parse %y) @>
        return <@ () @>
    }
let example : Zir<int, int, unit> = example1 >>> example2


let rec run : Expr<'I> -> (Expr<'O> -> Expr<unit>) -> Zir<'I, 'O, 'V> -> Expr<'V> =
    fun input output z ->
        match z with
        | Done v -> v
        | Yield (z', o) -> <@ let o' = %o in (% lambda (fun o' -> output o')) o'; (% run input output z') @>
        | NeedInput f -> <@ let i = %input in (% lambda(fun i -> run input output (f i))) i @>

let example' =
    <@ for i = 1 to 10 do
         (% lambda (fun i -> run i (fun o -> <@ printfn "%d" %o @>) example)) i
    @>

let _ = QuotationCompiler.ToFunc example' ()
namespace System
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
type Zir<'I,'O,'V> =
  | Yield of Zir<'I,'O,'V> * Expr<'O>
  | Done of Expr<'V>
  | NeedInput of (Expr<'I> -> Zir<'I,'O,'V>)

Full name: Script.Zir<_,_,_>
union case Zir.Yield: Zir<'I,'O,'V> * Expr<'O> -> Zir<'I,'O,'V>
union case Zir.Done: Expr<'V> -> Zir<'I,'O,'V>
union case Zir.NeedInput: (Expr<'I> -> Zir<'I,'O,'V>) -> Zir<'I,'O,'V>
val emit : o:Expr<'O> -> Zir<'I,'O,unit>

Full name: Script.emit
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val o : Expr<'O>
val take : Zir<'I,'O,'I>

Full name: Script.take
val return' : arg0:Expr<'V> -> Zir<'I,'O,'V>

Full name: Script.return'
val bind : z:Zir<'I,'O,'V> -> f:(Expr<'V> -> Zir<'I,'O,'W>) -> Zir<'I,'O,'W>

Full name: Script.bind
val z : Zir<'I,'O,'V>
val f : (Expr<'V> -> Zir<'I,'O,'W>)
val v : Expr<'V>
val z' : Zir<'I,'O,'V>
val g : (Expr<'I> -> Zir<'I,'O,'V>)
val i : Expr<'I>
val z1 : Zir<'I,'M,'V>
val z2 : Zir<'M,'O,'V>
val go2 : (Zir<'I,'M,'V> -> Zir<'M,'O,'V> -> Zir<'I,'O,'V>)
val z2' : Zir<'M,'O,'V>
val g : (Expr<'M> -> Zir<'M,'O,'V>)
val go1 : ((Expr<'M> -> Zir<'M,'O,'V>) -> Zir<'I,'M,'V> -> Zir<'I,'O,'V>)
val z : Zir<'I,'M,'V>
val z1' : Zir<'I,'M,'V>
val o : Expr<'M>
val g' : (Expr<'I> -> Zir<'I,'M,'V>)
Multiple items
type ZirBuilder =
  new : unit -> ZirBuilder
  member Bind : z:Zir<'I,'O,'V> * f:(Expr<'V> -> Zir<'I,'O,'W>) -> Zir<'I,'O,'W>
  member Return : v:Expr<'V> -> Zir<'a,'b,'V>

Full name: Script.ZirBuilder

--------------------
new : unit -> ZirBuilder
val self : ZirBuilder
member ZirBuilder.Return : v:Expr<'V> -> Zir<'a,'b,'V>

Full name: Script.ZirBuilder.Return
member ZirBuilder.Bind : z:Zir<'I,'O,'V> * f:(Expr<'V> -> Zir<'I,'O,'W>) -> Zir<'I,'O,'W>

Full name: Script.ZirBuilder.Bind
val zir : ZirBuilder

Full name: Script.zir
val example1 : Zir<int,string,unit>

Full name: Script.example1
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<_>
Multiple items
val string : value:'T -> string

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

--------------------
type string = String

Full name: Microsoft.FSharp.Core.string
val x : Expr<int>
val example2 : Zir<string,int,unit>

Full name: Script.example2
val x : Expr<string>
val y : Expr<string>
type Int32 =
  struct
    member CompareTo : value:obj -> int + 1 overload
    member Equals : obj:obj -> bool + 1 overload
    member GetHashCode : unit -> int
    member GetTypeCode : unit -> TypeCode
    member ToString : unit -> string + 3 overloads
    static val MaxValue : int
    static val MinValue : int
    static member Parse : s:string -> int + 3 overloads
    static member TryParse : s:string * result:int -> bool + 1 overload
  end

Full name: System.Int32
Int32.Parse(s: string) : int
Int32.Parse(s: string, provider: IFormatProvider) : int
Int32.Parse(s: string, style: Globalization.NumberStyles) : int
Int32.Parse(s: string, style: Globalization.NumberStyles, provider: IFormatProvider) : int
val example : Zir<int,int,unit>

Full name: Script.example
val run : input:Expr<'I> -> output:(Expr<'O> -> Expr<unit>) -> z:Zir<'I,'O,'V> -> Expr<'V>

Full name: Script.run
val input : Expr<'I>
val output : (Expr<'O> -> Expr<unit>)
val o' : 'O
val o' : Expr<'O>
val f : (Expr<'I> -> Zir<'I,'O,'V>)
val i : 'I
val example' : Expr<unit>

Full name: Script.example'
val i : int
val i : Expr<int>
val o : Expr<int>
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
Raw view Test code New version

More information

Link:http://fssnip.net/7Ta
Posted:7 years ago
Author:NIck Palladinos
Tags: staging , streams