F# rewrite computation expression - functional-programming

I'm studying continuations because I want to make some interesting use of coroutines... anyway, I want to better understand one implementation I found.
To do so I want to rewrite the implementation without using the computation expression (continuation Monad), but I'm not quite able to do it.
I have this:
type K<'T,'r> = (('T -> 'r) -> 'r)
let returnK x = (fun k -> k x)
let bindK m f = (fun k -> m (fun a -> f a k))
let runK (c:K<_,_>) cont = c cont
let callcK (f: ('T -> K<'b,'r>) -> K<'T,'r>) : K<'T,'r> =
fun cont -> runK (f (fun a -> (fun _ -> cont a))) cont
type ContinuationBuilder() =
member __.Return(x) = returnK x
member __.ReturnFrom(x) = x
member __.Bind(m,f) = bindK m f
member this.Zero () = this.Return ()
let K = new ContinuationBuilder()
/// The coroutine type from http://fssnip.net/7M
type Coroutine() =
let tasks = new System.Collections.Generic.Queue<K<unit,unit>>()
member this.Put(task) =
let withYield = K {
do! callcK (fun exit ->
task (fun () ->
callcK (fun c ->
tasks.Enqueue(c())
exit ())))
if tasks.Count <> 0 then
do! tasks.Dequeue() }
tasks.Enqueue(withYield)
member this.Run() =
runK (tasks.Dequeue()) ignore
// from FSharpx tests
let ``When running a coroutine it should yield elements in turn``() =
// This test comes from the sample on http://fssnip.net/7M
let actual = System.Text.StringBuilder()
let coroutine = Coroutine()
coroutine.Put(fun yield' -> K {
actual.Append("A") |> ignore
do! yield' ()
actual.Append("B") |> ignore
do! yield' ()
actual.Append("C") |> ignore
do! yield' ()
})
coroutine.Put(fun yield' -> K {
actual.Append("1") |> ignore
do! yield' ()
actual.Append("2") |> ignore
do! yield' ()
})
coroutine.Run()
actual.ToString() = "A1B2C"
``When running a coroutine it should yield elements in turn``()
So, I want rewrite the Put member of the Coroutine class without using the computation expression K.
I have read of course this and this and several other articles about catamorphisms but it is not quite easy to rewrite this continuation monand as it is to rewrite the Write Monad for example...
I try several ways, this is one of them:
member this.Put(task) =
let withYield =
bindK
(callcK (fun exit ->
task (fun () ->
callcK (fun c ->
tasks.Enqueue(c())
exit ()))))
(fun () ->
if tasks.Count <> 0
then tasks.Dequeue()
else returnK ())
tasks.Enqueue(withYield)
Of course it does not work :(
(By the way: there is some extensive documentation of all rules the compiler apply to rewrite the computation in plain F#?)

Your version of Put is almost correct. Two issues though:
The bindK function is being used backwards, the parameters need to be swaped.
task should be passed a Cont<_,_> -> Cont<_,_>, not a unit -> Cont<_,_> -> Cont<_,_>.
Fixing those issues it could look like this:
member this.Put(task) =
let withYield =
bindK
(fun () ->
if tasks.Count <> 0
then tasks.Dequeue()
else returnK ())
(callcK (fun exit ->
task (
callcK (fun c ->
tasks.Enqueue(c())
exit ()))))
tasks.Enqueue(withYield)
Of course it is not too elegant.
When using bind it is better to declare an operator >>=:
let (>>=) c f = bindK f c
that way
do! translates to putting >>= fun () -> after
let! a = translates to putting >>= fun a -> after
and then your code will look a little bit better:
member this.Put2(task) =
let withYield =
callcK( fun exit ->
task( callcK (fun c ->
tasks.Enqueue(c())
exit())
)
) >>= fun () ->
if tasks.Count <> 0 then
tasks.Dequeue()
else returnK ()
tasks.Enqueue withYield

Related

Why is this lazy evaluation function not working in OCaml

I made this example up to better understand how lazy evaluation works in OCaml - using thonks.
let rec imp n = fun () -> imp(n*n);;
My understanding of lazy evaluation / thonks is that impl will
square an initial number as often as I'm calling
imp ().
However this function imp raises the following error:
---
let rec imp n acc = fun()->(***imp (n\*acc)***);;
This expression has type int -> unit -> 'a
but an expression was expected of type 'a
The type variable 'a occurs inside int -> unit -> 'a
---
The compiler is telling you that your function has a recursive type. You can work with recursive types if you supply -rectypes when you run ocaml:
$ ocaml -rectypes
OCaml version 4.10.0
# let rec imp n = fun () -> imp(n*n);;
val imp : int -> (unit -> 'a as 'a) = <fun>
On the other hand I don't think your function works like you think. Or at least I don't see any way to find out what number it has recently calculated. You'll have to take it on faith that it is calculating larger and larger numbers, I guess.
I would investigate the Seq module and use that.
Here's an example that demonstrates what you are trying to accomplish:
type func = Func of (unit -> int * func)
let rec incr_by_2 x =
let ans = x + 2 in
(ans, Func(fun () -> incr_by_2 ans))
let ans = incr_by_2 10
let () =
match ans with
| (d, Func f) -> print_endline(string_of_int d);
match f() with
| (d, Func f) -> print_endline(string_of_int d);
match f() with
| (d, _) -> print_endline(string_of_int d);
Please note the type constructor Func which is used to resolve the type problem in the function incr_by_2.
Here's an example using the Seq module's unfold function.
type func = Func of (unit -> int * func)
let rec incr_by_2 x =
let ans = x + 2 in
(ans, Func(fun () -> incr_by_2 ans))
let seq x =
Seq.unfold
(
fun (d, Func f) ->
if d < x
then
Some(d, f())
else
None
)
(incr_by_2 10)
let () =
(seq 100) |> Seq.iter (Printf.printf "%d\n"); print_newline()

F# continuation recursion bug

I'm having an issue with a recursive function that runs into a stack overflow on larger data sets so I've attempted to rewrite the function to use continuous recursion but to say I'm new to this would be an understatement. In the below example the first function, processList, gives the desired results on a small data set. The second function, processListCont, seems to work however I know there must be a bug since when I run the same small data set through it I get different results. Would processListCont be the correct way to express the processList function or am I missing something?
open System
type Something(id) =
member val id = id with get, set
member val children : list<Something> = [] with get, set
member val processed : bool = false with get, set
let rec processList (item:Something, itemList:list<Something>) =
for child in item.children do
let parent = itemList |> Seq.find (fun (i:Something) -> i.id = child.id)
if parent.processed = false then
parent.processed <- true
processList(parent, itemList)
let processListCont (item:Something, itemList:list<Something>) =
let rec _processListCont (item:Something, itemList:list<Something>, f) =
for child in item.children do
let parent = itemList |> Seq.find (fun (i:Something) -> i.id = child.id)
if parent.processed = false then
parent.processed <- true
f(parent, itemList)
_processListCont(item, itemList, (fun (item:Something, itemList:list<Something>) -> ()))
[<EntryPoint>]
let main argv =
// generate some data
let count = 10000
let idList = List.init count (fun index -> index)
let items = [for (id) in idList -> Something id]
let rnd = System.Random()
for i in items do
i.children <- List.init 100 (fun _ -> Something (rnd.Next(0, count - 1)))
// process the list
for i in items do
processList(i, items)
Console.WriteLine("Processing completed successfully")
Console.ReadKey()
|> ignore
0
The main issue is that you are calling the continuation f in the body of the for loop, but your non-tail-recursive version makes a recurisve call here.
This is tricky because you want to make a recursive call and the continuation should be "run the rest of the for loop". To express this, you'll need to use pattern matching instead of for loop.
I did not have a small example to test this, but I think something like this should do the trick:
let rec processListCont (item:Something, itemList:list<Something>) cont =
let rec loop (children:list<Something>) cont =
match children with
| child::tail ->
let parent = itemList |> Seq.find (fun (i:Something) -> i.id = child.id)
if parent.processed = false then
parent.processed <- true
processListCont (parent, itemList) (fun () -> loop tail cont)
| [] -> cont ()
loop item.children cont
Your code is unidiomatic in F# nonetheless consider the following example.
Suppose you want to add a list of numbers. You could write a function like this:
let rec add (l:int list) :int =
match l with
| [] -> 0
| x::xs -> x + (add xs)
but this would overflow the stack very quickly. Instead you could use cps to allow the code to become tail recursive:
type
cont = int -> int
let rec add2 (l:int list) (k:cont):int =
match l with
| [] -> k 0
| x::xs -> add2 xs (fun a -> k (a + x))
which you can use like this:
printfn "%i" (add2 [1..10000] id)
In a similar fashion you could rewrite your function like this:
type cont2 = Something list->unit
let rec p (item:Something, itemList:list<Something>) (k:cont2) =
match item.children with
| [] -> k []
| child::xs ->
let parent = itemList |> Seq.find (fun (i:Something) -> i.id = child.id)
if parent.processed = false then
parent.processed <- true
p (parent, itemList) (fun _ ->k xs)
else
k xs
let p2 (item:Something,itemList:Something list) = p (item,itemList) ignore
and you can call it like this:
for i in items do
p2(i, items)

Asynchronous mapFold

For the following example, Array.mapFold produces the result ([|1; 4; 12|], 7).
let mapping s x = (s * x, s + x)
[| 1..3 |]
|> Array.mapFold mapping 1
Now suppose our mapping is asynchronous.
let asyncMapping s x = async { return (s * x, s + x) }
I am able to create Array.mapFoldAsync for the following to work.
[| 1..3 |]
|> Array.mapFoldAsync asyncMapping 1
|> Async.RunSynchronously
Is there a succinct way to achieve this without creating Array.mapFoldAsync?
I am asking as a way to learn other techniques - my attempts using Array.fold were horrible.
I don't think it would generally be of much benefit to combine mapFold with an Async function, because the expected result is a tuple ('values * 'accumulator), but using an Async function will at best give you an Async<'values * 'accumulator>. Consider the following attempt to make Array.mapFold work with Async:
let mapping s x = async {
let! s' = s
let! x' = x
return (s' * x', s' + x')
}
[| 1..3 |]
|> Array.map async.Return
|> Array.mapFold mapping (async.Return 1)
Even this doesn't work, because of the type mismatch: The type ''a * Async<'b>' does not match the type 'Async<'c * 'd>'.
You may also have noticed that while there is an Array.Parallel.map, there's no Array.Parallel.fold or Array.Parallel.mapFold. If you try to write your own mapFoldAsync, you may see why. The mapping part is pretty easy, just partially apply Array.map and compose with Async.Parallel:
let mapAsync f = Array.map f >> Async.Parallel
You can implement an async fold as well, but since each evaluation depends on the previous result, you can't leverage Async.Parallel this time:
let foldAsync f state array =
match array |> Array.length with
| 0 -> async.Return state
| length ->
async {
let mutable acc = state
for i = 0 to length - 1 do
let! value = f acc array.[i]
acc <- value
return acc
}
Now, when we try to combine these to build a mapFoldAsync, it becomes apparent that we can't leverage parallel execution on the mapping anymore, because both the values and the accumulator can be based on the result of the previous evaluation. That means our mapFoldAsync will be a modified 'foldAsync', not a composition of it with mapAsync:
let mapFoldAsync (f: 's -> 'a -> Async<'b * 's>) (state: 's) (array: 'a []) =
match array |> Array.length with
| 0 -> async.Return ([||], state)
| length ->
async {
let mutable acc = state
let results = Array.init length <| fun _ -> Unchecked.defaultof<'b>
for i = 0 to length - 1 do
let! (x,y) = f acc array.[i]
results.[i] <- x
acc <- y
return (results, acc)
}
While this will give you a way to do a mapFold with an async mapping function, the only real benefit would be if the mapping function did something with high-latency, such as a service call. You won't be able to leverage parallel execution for speed-up. If possible, I would suggest considering an alternative solution, based on your real-world scenario.
Without external libraries (I recommend to try AsyncSeq or Hopac.Streams)
you could do this:
let mapping s x = (fst s * x, snd s + x) |> async.Return
module Array =
let mapFoldAsync folderAsync (state: 'state) (array: 'elem []) = async {
let mutable finalState = state
for elem in array do
let! nextState = folderAsync finalState elem
finalState <- nextState
return finalState
}
[| 1..4 |]
|> Array.mapFoldAsync mapping (1,0)
|> Async.RunSynchronously

F# async workflow / tasks combined with free monad

I'm trying to build pipeline for message handling using free monad pattern, my code looks like that:
module PipeMonad =
type PipeInstruction<'msgIn, 'msgOut, 'a> =
| HandleAsync of 'msgIn * (Async<'msgOut> -> 'a)
| SendOutAsync of 'msgOut * (Async -> 'a)
let private mapInstruction f = function
| HandleAsync (x, next) -> HandleAsync (x, next >> f)
| SendOutAsync (x, next) -> SendOutAsync (x, next >> f)
type PipeProgram<'msgIn, 'msgOut, 'a> =
| Act of PipeInstruction<'msgIn, 'msgOut, PipeProgram<'msgIn, 'msgOut, 'a>>
| Stop of 'a
let rec bind f = function
| Act x -> x |> mapInstruction (bind f) |> Act
| Stop x -> f x
type PipeBuilder() =
member __.Bind (x, f) = bind f x
member __.Return x = Stop x
member __.Zero () = Stop ()
member __.ReturnFrom x = x
let pipe = PipeBuilder()
let handleAsync msgIn = Act (HandleAsync (msgIn, Stop))
let sendOutAsync msgOut = Act (SendOutAsync (msgOut, Stop))
which I wrote according to this article
However it's important to me to have those methods asynchronous (Task preferably, but Async is acceptable), but when I created a builder for my pipeline, I can't figure out how to use it - how can I await a Task<'msgOut> or Async<'msgOut> so I can send it out and await this "send" task?
Now I have this piece of code:
let pipeline log msgIn =
pipe {
let! msgOut = handleAsync msgIn
let result = async {
let! msgOut = msgOut
log msgOut
return sendOutAsync msgOut
}
return result
}
which returns PipeProgram<'b, 'a, Async<PipeProgram<'c, 'a, Async>>>
In my understanding, the whole point of the free monad is that you don't expose effects like Async, so I don't think they should be used in the PipeInstruction type. The interpreter is where the effects get added.
Also, the Free Monad really only makes sense in Haskell, where all you need to do is define a functor, and then you get the rest of the implementation automatically. In F# you have to write the rest of the code as well, so there is not much benefit to using Free over a more traditional interpreter pattern.
That TurtleProgram code you linked to was just an experiment -- I would not recommend using Free for real code at all.
Finally, if you already know the effects you are going to use, and you are not going to have more than one interpretation, then using this approach doesn't make sense. It only makes sense when the benefits outweigh the complexity.
Anyway, if you did want to write an interpreter version (rather than Free) this is how I would do it:
First, define the instructions without any effects.
/// The abstract instruction set
module PipeProgram =
type PipeInstruction<'msgIn, 'msgOut,'state> =
| Handle of 'msgIn * ('msgOut -> PipeInstruction<'msgIn, 'msgOut,'state>)
| SendOut of 'msgOut * (unit -> PipeInstruction<'msgIn, 'msgOut,'state>)
| Stop of 'state
Then you can write a computation expression for it:
/// A computation expression for a PipeProgram
module PipeProgramCE =
open PipeProgram
let rec bind f instruction =
match instruction with
| Handle (x,next) -> Handle (x, (next >> bind f))
| SendOut (x, next) -> SendOut (x, (next >> bind f))
| Stop x -> f x
type PipeBuilder() =
member __.Bind (x, f) = bind f x
member __.Return x = Stop x
member __.Zero () = Stop ()
member __.ReturnFrom x = x
let pipe = PipeProgramCE.PipeBuilder()
And then you can start writing your computation expressions. This will help flush out the design before you start on the interpreter.
// helper functions for CE
let stop x = PipeProgram.Stop x
let handle x = PipeProgram.Handle (x,stop)
let sendOut x = PipeProgram.SendOut (x, stop)
let exampleProgram : PipeProgram.PipeInstruction<string,string,string> = pipe {
let! msgOut1 = handle "In1"
do! sendOut msgOut1
let! msgOut2 = handle "In2"
do! sendOut msgOut2
return msgOut2
}
Once you have described the the instructions, you can then write the interpreters. And as I said, if you are not writing multiple interpreters, then perhaps you don't need to do this at all.
Here's an interpreter for a non-async version (the "Id monad", as it were):
module PipeInterpreterSync =
open PipeProgram
let handle msgIn =
printfn "In: %A" msgIn
let msgOut = System.Console.ReadLine()
msgOut
let sendOut msgOut =
printfn "Out: %A" msgOut
()
let rec interpret instruction =
match instruction with
| Handle (x, next) ->
let result = handle x
result |> next |> interpret
| SendOut (x, next) ->
let result = sendOut x
result |> next |> interpret
| Stop x ->
x
and here's the async version:
module PipeInterpreterAsync =
open PipeProgram
/// Implementation of "handle" uses async/IO
let handleAsync msgIn = async {
printfn "In: %A" msgIn
let msgOut = System.Console.ReadLine()
return msgOut
}
/// Implementation of "sendOut" uses async/IO
let sendOutAsync msgOut = async {
printfn "Out: %A" msgOut
return ()
}
let rec interpret instruction =
match instruction with
| Handle (x, next) -> async {
let! result = handleAsync x
return! result |> next |> interpret
}
| SendOut (x, next) -> async {
do! sendOutAsync x
return! () |> next |> interpret
}
| Stop x -> x
First of all, I think that using free monads in F# is very close to being an anti-pattern. It is a very abstract construction that does not fit all that great with idiomatic F# style - but that is a matter of preference and if you (and your team) finds this way of writing code readable and easy to understand, then you can certainly go in this direction.
Out of curiosity, I spent a bit of time playing with your example - although I have not quite figured out how to fix your example completely, I hope the following might help to steer you in the right direction. The summary is that I think you will need to integrate Async into your PipeProgram so that the pipe program is inherently asynchronous:
type PipeInstruction<'msgIn, 'msgOut, 'a> =
| HandleAsync of 'msgIn * (Async<'msgOut> -> 'a)
| SendOutAsync of 'msgOut * (Async<unit> -> 'a)
| Continue of 'a
type PipeProgram<'msgIn, 'msgOut, 'a> =
| Act of Async<PipeInstruction<'msgIn, 'msgOut, PipeProgram<'msgIn, 'msgOut, 'a>>>
| Stop of Async<'a>
Note that I had to add Continue to make my functions type-check, but I think that's probably a wrong hack and you might need to remote that. With these definitions, you can then do:
let private mapInstruction f = function
| HandleAsync (x, next) -> HandleAsync (x, next >> f)
| SendOutAsync (x, next) -> SendOutAsync (x, next >> f)
| Continue v -> Continue v
let rec bind (f:'a -> PipeProgram<_, _, _>) = function
| Act x ->
let w = async {
let! x = x
return mapInstruction (bind f) x }
Act w
| Stop x ->
let w = async {
let! x = x
let pg = f x
return Continue pg
}
Act w
type PipeBuilder() =
member __.Bind (x, f) = bind f x
member __.Return x = Stop x
member __.Zero () = Stop (async.Return())
member __.ReturnFrom x = x
let pipe = PipeBuilder()
let handleAsync msgIn = Act (async.Return(HandleAsync (msgIn, Stop)))
let sendOutAsync msgOut = Act (async.Return(SendOutAsync (msgOut, Stop)))
let pipeline log msgIn =
pipe {
let! msgOut = handleAsync msgIn
log msgOut
return! sendOutAsync msgOut
}
pipeline ignore 0
This now gives you just plain PipeProgram<int, unit, unit> which you should be able to evaluate by having a recursive asynchronous functions that acts on the commands.

Mutually recursive let bindings

I'm trying to implement a parser that looks something like this:
open System
type ParseResult<'a> =
{
Result : Option<'a>;
Rest : string
}
let Fail = fun input -> { Result = None; Rest = input }
let Return a = fun input -> { Result = Some a; Rest = input }
let ThenBind p f =
fun input ->
let r = p input
match r.Result with
| None -> { Result = None; Rest = input } // Recreate the result since p returns a ParseResult<'a>
| _ -> (f r.Result) r.Rest
let Then p1 p2 = ThenBind p1 (fun r -> p2)
let Or p1 p2 =
fun input ->
let r = p1 input
match r.Result with
| None -> p2 input
| _ -> r
let rec Chainl1Helper a p op =
Or
<| ThenBind op (fun f ->
ThenBind p (fun y ->
Chainl1Helper (f.Value a y.Value) p op))
<| Return a
let Chainl1 p op = ThenBind p (fun x -> Chainl1Helper x.Value p op)
let rec Chainr1 p op =
ThenBind p (fun x ->
Or
(ThenBind op (fun f ->
ThenBind (Chainr1 p op) (fun y ->
Return (f.Value x.Value y.Value))))
(Return x.Value))
let Next = fun input ->
match input with
| null -> { Result = None; Rest = input }
| "" -> { Result = None; Rest = input }
| _ -> { Result = Some <| char input.[0..1]; Rest = input.[1..] }
let Sat predicate = ThenBind Next (fun n -> if predicate n.Value then Return n.Value else Fail)
let Digit = ThenBind (Sat Char.IsDigit) (fun c -> Return <| float c.Value)
let rec NatHelper i =
Or
(ThenBind Digit (fun x ->
NatHelper (float 10 * i + x.Value) ))
(Return i)
let Nat = ThenBind Digit (fun d -> NatHelper d.Value)
let LiteralChar c = Sat (fun x -> x = c)
let rec Literal input token =
match input with
| "" -> Return token
| _ -> Then (LiteralChar <| char input.[0..1]) (Literal input.[1..] token)
let AddSub =
Or
<| ThenBind (LiteralChar '+') (fun c -> Return (+))
<| ThenBind (LiteralChar '-') (fun c -> Return (-))
let MulDiv =
Or
<| ThenBind (LiteralChar '*') (fun c -> Return (*))
<| ThenBind (LiteralChar '/') (fun c -> Return (/))
let Exp = ThenBind (LiteralChar '^') (fun c -> Return ( ** ))
let rec Expression = Chainl1 Term AddSub
and Term = Chainl1 Factor MulDiv
and Factor = Chainr1 Part Exp
and Part = Or Nat Paren
and Paren =
Then
<| LiteralChar '('
<| ThenBind Expression (fun e ->
Then (LiteralChar ')') (Return e.Value))
The last functions are mutually recursive in their definitions. Expression's definition depends on Term, which depends on Factor, which depends on Part, which depends on Paren, which depends on Expression.
When I try to compile this, I get an error about mutually recursive definitions with the suggestion to make Expression lazy or a function. I tried both of those, and I get a cryptic InvalidOperationException with both that says something about ValueFactory attempting to access the Value property.
In general, F# lets you use let rec .. and .. not just for defining mutually recursive functions, but also for defining mutually recursive values. This means that you might be able to write something like this:
let rec Expression = Chainl1 Term AddSub
and Paren =
Then
<| LiteralChar '('
<| ThenBind Expression (fun e ->
Then (LiteralChar ')') (Return e.Value))
and Part = Or Nat Paren
and Factor = Chainr1 Part Exp
and Term = Chainl1 Factor MulDiv
However, this only works if the computation is not evaluated immediately (because then the recursive definition would not make sense). This very much depends on the library you're using here (or on the rest of your code). But you can try the above and see if that works - if no, you'll need to provide more details.
EDIT In the updated example, there is an immediate loop in your recursive definition. You need to delay some part of the definition using fun _ -> ... so that not everything needs to be evaluated at once. In your example, you can do that by replacing Then with ThenBind in the definition of Paren:
let rec Expression = Chainl1 Term AddSub
and Term = Chainl1 Factor MulDiv
and Factor = Chainr1 Part Exp
and Part = Or Nat Paren
and Paren =
ThenBind
(LiteralChar '(')
(fun _ -> ThenBind Expression (fun e ->
Then (LiteralChar ')') (Return e.Value)))

Resources