Can you implement CPS using computation expressions in F#?
Brian McNamara's blog gives this solution:
type ContinuationBuilder() =
member this.Return(x) = (fun k -> k x)
member this.ReturnFrom(x) = x
member this.Bind(m,f) = (fun k -> m (fun a -> f a k))
member this.Delay(f) = f()
let cps = ContinuationBuilder()
Looks good. I can write List.map in CPS:
let rec mapk f xs = cps {
match xs with
| [] -> return []
| x::xs ->
let! xs = mapk f xs
return f x::xs
}
But it stack overflows:
mapk ((+) 1) [1..1000000] id
What am I doing wrong?
The problem is that your Delay function in the computation builder is immediately calling the function - this means that when you call mapk, it will immediately run the pattern matching and then call mapk recursively (before passing its result to the Bind operation).
You can fix this by using an implementation of Delay that returns a function which invokes f only after it is given a final continuation - this way, the recursive call will just return a function (without doing more recursive calls that cause stack overflow):
member this.Delay(f) = (fun k -> f () k)
With this version of Delay, the your code works as expected for me.
Related
I'm trying to explore the dynamic capabilities of F# for situations where I can't express some function with the static type system. As such, I'm trying to create a mapN function for (say) Option types, but I'm having trouble creating a function with a dynamic number of arguments. I've tried:
let mapN<'output> (f : obj) args =
let rec mapN' (state:obj) (args' : (obj option) list) =
match args' with
| Some x :: xs -> mapN' ((state :?> obj -> obj) x) xs
| None _ :: _ -> None
| [] -> state :?> 'output option
mapN' f args
let toObjOption (x : #obj option) =
Option.map (fun x -> x :> obj) x
let a = Some 5
let b = Some "hi"
let c = Some true
let ans = mapN<string> (fun x y z -> sprintf "%i %s %A" x y z) [a |> toObjOption; b |> toObjOption; c |> toObjOption]
(which takes the function passed in and applies one argument at a time) which compiles, but then at runtime I get the following:
System.InvalidCastException: Unable to cast object of type 'ans#47' to type
'Microsoft.FSharp.Core.FSharpFunc`2[System.Object,System.Object]'.
I realize that it would be more idiomatic to either create a computation expression for options, or to define map2 through map5 or so, but I specifically want to explore the dynamic capabilities of F# to see whether something like this would be possible.
Is this just a concept that can't be done in F#, or is there an approach that I'm missing?
I think you would only be able to take that approach with reflection.
However, there are other ways to solve the overall problem without having to go dynamic or use the other static options you mentioned. You can get a lot of the same convenience using Option.apply, which you need to define yourself (or take from a library). This code is stolen and adapted from F# for fun and profit:
module Option =
let apply fOpt xOpt =
match fOpt,xOpt with
| Some f, Some x -> Some (f x)
| _ -> None
let resultOption =
let (<*>) = Option.apply
Some (fun x y z -> sprintf "%i %s %A" x y z)
<*> Some 5
<*> Some "hi"
<*> Some true
To explain why your approach does not work, the problem is that you cannot cast a function of type int -> int (represented as FSharpFunc<int, int>) to a value of type obj -> obj (represented as FSharpFunc<obj, obj>). The types are the same generic types, but the cast fails because the generic parameters are different.
If you insert a lot of boxing and unboxing, then your function actually works, but this is probably not something you want to write:
let ans = mapN<string> (fun (x:obj) -> box (fun (y:obj) -> box (fun (z:obj) ->
box (Some(sprintf "%i %s %A" (unbox x) (unbox y) (unbox z))))))
[a |> toObjOption; b |> toObjOption; c |> toObjOption]
If you wanted to explore more options possible thanks to dynamic hacks - then you can probably do more using F# reflection. I would not typically use this in production (simple is better - I'd just define multiple map functions by hand or something like that), but the following runs:
let rec mapN<'R> f args =
match args with
| [] -> unbox<'R> f
| x::xs ->
let m = f.GetType().GetMethods() |> Seq.find (fun m ->
m.Name = "Invoke" && m.GetParameters().Length = 1)
mapN<'R> (m.Invoke(f, [| x |])) xs
mapN<obj> (fun a b c -> sprintf "%d %s %A" a b c) [box 1; box "hi"; box true]
I'm attempting to rewrite List.filter manually
so far I have this:
let rec filter f = function
|[] -> []
|x::xs -> if f x = true then x # filter f xs
else filter f xs;;
I'd add to the accepted answer that recognizing and applying functional patterns may be as important as mastery of recursion and pattern matching. And probably the first of such patterns is folding.
Implementing your task with folding takes a terse:
let filter p ls = List.foldBack (fun l acc -> if p l then l::acc else acc) ls []
Operator # appends 2 lists so x in if ... then ... else expression is supposed to be of type list.
You probably meant to use list cons operator ::. Also you don't need to compare the result of function f application to true.
let rec filter f = function
|[] -> []
|x::xs -> if f x then x :: filter f xs
else filter f xs
[1;2;3;4;5;6;7;8;9] |> filter (fun x -> x % 2 = 0)
val it : int list = [2; 4; 6; 8]
Note: this function is not tail recursive so you'll get stack overflow exception with big lists.
I should split seq<a> into seq<seq<a>> by an attribute of the elements. If this attribute equals by a given value it must be 'splitted' at that point. How can I do that in FSharp?
It should be nice to pass a 'function' to it that returns a bool if must be splitted at that item or no.
Sample:
Input sequence: seq: {1,2,3,4,1,5,6,7,1,9}
It should be splitted at every items when it equals 1, so the result should be:
seq
{
seq{1,2,3,4}
seq{1,5,6,7}
seq{1,9}
}
All you're really doing is grouping--creating a new group each time a value is encountered.
let splitBy f input =
let i = ref 0
input
|> Seq.map (fun x ->
if f x then incr i
!i, x)
|> Seq.groupBy fst
|> Seq.map (fun (_, b) -> Seq.map snd b)
Example
let items = seq [1;2;3;4;1;5;6;7;1;9]
items |> splitBy ((=) 1)
Again, shorter, with Stephen's nice improvements:
let splitBy f input =
let i = ref 0
input
|> Seq.groupBy (fun x ->
if f x then incr i
!i)
|> Seq.map snd
Unfortunately, writing functions that work with sequences (the seq<'T> type) is a bit difficult. They do not nicely work with functional concepts like pattern matching on lists. Instead, you have to use the GetEnumerator method and the resulting IEnumerator<'T> type. This often makes the code quite imperative. In this case, I'd write the following:
let splitUsing special (input:seq<_>) = seq {
use en = input.GetEnumerator()
let finished = ref false
let start = ref true
let rec taking () = seq {
if not (en.MoveNext()) then finished := true
elif en.Current = special then start := true
else
yield en.Current
yield! taking() }
yield taking()
while not (!finished) do
yield Seq.concat [ Seq.singleton special; taking()] }
I wouldn't recommend using the functional style (e.g. using Seq.skip and Seq.head), because this is quite inefficient - it creates a chain of sequences that take value from other sequence and just return it (so there is usually O(N^2) complexity).
Alternatively, you could write this using a computation builder for working with IEnumerator<'T>, but that's not standard. You can find it here, if you want to play with it.
The following is an impure implementation but yields immutable sequences lazily:
let unflatten f s = seq {
let buffer = ResizeArray()
let flush() = seq {
if buffer.Count > 0 then
yield Seq.readonly (buffer.ToArray())
buffer.Clear() }
for item in s do
if f item then yield! flush()
buffer.Add(item)
yield! flush() }
f is the function used to test whether an element should be a split point:
[1;2;3;4;1;5;6;7;1;9] |> unflatten (fun item -> item = 1)
Probably no the most efficient solution, but this works:
let takeAndSkipWhile f s = Seq.takeWhile f s, Seq.skipWhile f s
let takeAndSkipUntil f = takeAndSkipWhile (f >> not)
let rec splitOn f s =
if Seq.isEmpty s then
Seq.empty
else
let pre, post =
if f (Seq.head s) then
takeAndSkipUntil f (Seq.skip 1 s)
|> fun (a, b) ->
Seq.append [Seq.head s] a, b
else
takeAndSkipUntil f s
if Seq.isEmpty pre then
Seq.singleton post
else
Seq.append [pre] (splitOn f post)
splitOn ((=) 1) [1;2;3;4;1;5;6;7;1;9] // int list is compatible with seq<int>
The type of splitOn is ('a -> bool) -> seq<'a> -> seq>. I haven't tested it on many inputs, but it seems to work.
In case you are looking for something which actually works like split as an string split (i.e the item is not included on which the predicate returns true) the below is what I came up with.. tried to be as functional as possible :)
let fromEnum (input : 'a IEnumerator) =
seq {
while input.MoveNext() do
yield input.Current
}
let getMore (input : 'a IEnumerator) =
if input.MoveNext() = false then None
else Some ((input |> fromEnum) |> Seq.append [input.Current])
let splitBy (f : 'a -> bool) (input : 'a seq) =
use s = input.GetEnumerator()
let rec loop (acc : 'a seq seq) =
match s |> getMore with
| None -> acc
| Some x ->[x |> Seq.takeWhile (f >> not) |> Seq.toList |> List.toSeq]
|> Seq.append acc
|> loop
loop Seq.empty |> Seq.filter (Seq.isEmpty >> not)
seq [1;2;3;4;1;5;6;7;1;9;5;5;1]
|> splitBy ( (=) 1) |> printfn "%A"
Disclosure: this came up in FsCheck, an F# random testing framework I maintain. I have a solution, but I do not like it. Moreover, I do not understand the problem - it was merely circumvented.
A fairly standard implementation of (monadic, if we're going to use big words) sequence is:
let sequence l =
let k m m' = gen { let! x = m
let! xs = m'
return (x::xs) }
List.foldBack k l (gen { return [] })
Where gen can be replaced by a computation builder of choice. Unfortunately, that implementation consumes stack space, and so eventually stack overflows if the list is long enough.The question is: why? I know in principle foldBack is not tail recursive, but the clever bunnies of the F# team have circumvented that in the foldBack implementation. Is there a problem in the computation builder implementation?
If I change the implementation to the below, everything is fine:
let sequence l =
let rec go gs acc size r0 =
match gs with
| [] -> List.rev acc
| (Gen g)::gs' ->
let r1,r2 = split r0
let y = g size r1
go gs' (y::acc) size r2
Gen(fun n r -> go l [] n r)
For completeness, the Gen type and computation builder can be found in the FsCheck source
Building on Tomas's answer, let's define two modules:
module Kurt =
type Gen<'a> = Gen of (int -> 'a)
let unit x = Gen (fun _ -> x)
let bind k (Gen m) =
Gen (fun n ->
let (Gen m') = k (m n)
m' n)
type GenBuilder() =
member x.Return(v) = unit v
member x.Bind(v,f) = bind f v
let gen = GenBuilder()
module Tomas =
type Gen<'a> = Gen of (int -> ('a -> unit) -> unit)
let unit x = Gen (fun _ f -> f x)
let bind k (Gen m) =
Gen (fun n f ->
m n (fun r ->
let (Gen m') = k r
m' n f))
type GenBuilder() =
member x.Return v = unit v
member x.Bind(v,f) = bind f v
let gen = GenBuilder()
To simplify things a bit, let's rewrite your original sequence function as
let rec sequence = function
| [] -> gen { return [] }
| m::ms -> gen {
let! x = m
let! xs = sequence ms
return x::xs }
Now, sequence [for i in 1 .. 100000 -> unit i] will run to completion regardless of whether sequence is defined in terms of Kurt.gen or Tomas.gen. The issue is not that sequence causes a stack overflow when using your definitions, it's that the function returned from the call to sequence causes a stack overflow when it is called.
To see why this is so, let's expand the definition of sequence in terms of the underlying monadic operations:
let rec sequence = function
| [] -> unit []
| m::ms ->
bind (fun x -> bind (fun xs -> unit (x::xs)) (sequence ms)) m
Inlining the Kurt.unit and Kurt.bind values and simplifying like crazy, we get
let rec sequence = function
| [] -> Kurt.Gen(fun _ -> [])
| (Kurt.Gen m)::ms ->
Kurt.Gen(fun n ->
let (Kurt.Gen ms') = sequence ms
(m n)::(ms' n))
Now it's hopefully clear why calling let (Kurt.Gen f) = sequence [for i in 1 .. 1000000 -> unit i] in f 0 overflows the stack: f requires a non-tail-recursive call to sequence and evaluation of the resulting function, so there will be one stack frame for each recursive call.
Inlining Tomas.unit and Tomas.bind into the definition of sequence instead, we get the following simplified version:
let rec sequence = function
| [] -> Tomas.Gen (fun _ f -> f [])
| (Tomas.Gen m)::ms ->
Tomas.Gen(fun n f ->
m n (fun r ->
let (Tomas.Gen ms') = sequence ms
ms' n (fun rs -> f (r::rs))))
Reasoning about this variant is tricky. You can empirically verify that it won't blow the stack for some arbitrarily large inputs (as Tomas shows in his answer), and you can step through the evaluation to convince yourself of this fact. However, the stack consumption depends on the Gen instances in the list that's passed in, and it is possible to blow the stack for inputs that aren't themselves tail recursive:
// ok
let (Tomas.Gen f) = sequence [for i in 1 .. 1000000 -> unit i]
f 0 (fun list -> printfn "%i" list.Length)
// not ok...
let (Tomas.Gen f) = sequence [for i in 1 .. 1000000 -> Gen(fun _ f -> f i; printfn "%i" i)]
f 0 (fun list -> printfn "%i" list.Length)
You're correct - the reason why you're getting a stack overflow is that the bind operation of the monad needs to be tail-recursive (because it is used to aggregate values during folding).
The monad used in FsCheck is essentially a state monad (it keeps the current generator and some number). I simplified it a bit and got something like:
type Gen<'a> = Gen of (int -> 'a)
let unit x = Gen (fun n -> x)
let bind k (Gen m) =
Gen (fun n ->
let (Gen m') = k (m n)
m' n)
Here, the bind function is not tail-recursive because it calls k and then does some more work. You can change the monad to be a continuation monad. It is implemented as a function that takes the state and a continuation - a function that is called with the result as an argument. For this monad, you can make bind tail recursive:
type Gen<'a> = Gen of (int -> ('a -> unit) -> unit)
let unit x = Gen (fun n f -> f x)
let bind k (Gen m) =
Gen (fun n f ->
m n (fun r ->
let (Gen m') = k r
m' n f))
The following example will not stack overflow (and it did with the original implementation):
let sequence l =
let k m m' =
m |> bind (fun x ->
m' |> bind (fun xs ->
unit (x::xs)))
List.foldBack k l (unit [])
let (Gen f) = sequence [ for i in 1 .. 100000 -> unit i ]
f 0 (fun list -> printfn "%d" list.Length)
Some background first. I am currently learning some stuff about monadic parser combinators. While I tried to transfer the 'chainl1' function from this paper (p. 16-17), I came up with this solution:
let chainl1 p op = parser {
let! x = p
let rec chainl1' (acc : 'a) : Parser<'a> =
let p' = parser {
let! f = op
let! y = p
return! chainl1' (f acc y)
}
p' <|> succeed acc
return! chainl1' x
}
I tested the function with some large input and got a StackOverflowException. Now I am wondering, is it posible to rewrite a recursive function, that uses some computation expression, in a way so it is using tail recursion?
When I expand the computation expression, I can not see how it would be generally possible.
let chainl1 p op =
let b = parser
b.Bind(p, (fun x ->
let rec chainl1' (acc : 'a) : Parser<'a> =
let p' =
let b = parser
b.Bind(op, (fun f ->
b.Bind(p, (fun y ->
b.ReturnFrom(chainl1' (f acc y))))))
p' <|> succeed acc
b.ReturnFrom(chainl1' x)))
In your code, the following function isn't tail-recursive, because - in every iteration - it makes a choice between either p' or succeed:
// Renamed a few symbols to avoid breaking SO code formatter
let rec chainl1Util (acc : 'a) : Parser<'a> =
let pOp = parser {
let! f = op
let! y = p
return! chainl1Util (f acc y) }
// This is done 'after' the call using 'return!', which means
// that the 'cahinl1Util' function isn't really tail-recursive!
pOp <|> succeed acc
Depending on your implementation of parser combinators, the following rewrite could work (I'm not an expert here, but it may be worth trying this):
let rec chainl1Util (acc : 'a) : Parser<'a> =
// Succeeds always returning the accumulated value (?)
let pSuc = parser {
let! r = succeed acc
return Choice1Of2(r) }
// Parses the next operator (if it is available)
let pOp = parser {
let! f = op
return Choice2Of2(f) }
// The main parsing code is tail-recursive now...
parser {
// We can continue using one of the previous two options
let! cont = pOp <|> pSuc
match cont with
// In case of 'succeed acc', we call this branch and finish...
| Choice1Of2(r) -> return r
// In case of 'op', we need to read the next sub-expression..
| Choice2Of2(f) ->
let! y = p
// ..and then continue (this is tail-call now, because there are
// no operations left - e.g. this isn't used as a parameter to <|>)
return! chainl1Util (f acc y) }
In general, the pattern for writing tail-recursive functions inside computation expressions works. Something like this will work (for computation expressions that are implemented in a way that allows tail-recursion):
let rec foo(arg) = id {
// some computation here
return! foo(expr) }
As you can check, the new version matches this pattern, but the original one did not.
In general it is possible to write tail-recursive computation expressions (see 1 and 2), even with multiple let! bindings thanks to the 'delay' mechanism.
In this case the last statement of chainl1 is what gets you into a corner I think.