I need a function that produces primes in F#. I found this:
let primesSeq =
let rec nextPrime n p primes =
if primes |> Map.containsKey n then
nextPrime (n + p) p primes
else
primes.Add(n, p)
let rec prime n primes =
seq {
if primes |> Map.containsKey n then
let p = primes.Item n
yield! prime (n + 1) (nextPrime (n + p) p (primes.Remove n))
else
yield n
yield! prime (n + 1) (primes.Add(n * n, n))
}
prime 2 Map.empty
This works very well, but sometimes I need to work with int64/BigInts as well. Is there a more clever way of reusing this code than providing another sequences like these:
let primesSeq64 = Seq.map int64 primesSeq
let primesBigInts = Seq.map (fun (x : int) -> BigInteger(x)) primesSeq
I've heard about modifying a code using "inline" and "LanguagePrimitives", but all I've found was connected with function while my problem is related to a value.
Moreover - I'd like to have a function that works with integer types and computes a floor of a square root.
let inline sqRoot arg = double >> Math.Sqrt >> ... ?
but I can't see a way of returning the same type as "arg" is, as Math.Sqrt returns a double. Again - is there anything better than reimplementing the logic that computes a square root by myself ?
So the general way to do this requires a function and languageprimitives - in your case everywhere you have 1 you write LanguagePrimitives.GenericOne which will produce 1 or 1.0 etc depending on what is required.
To get this to work, you need to create a function value - you can avoid this by doing something like:
let inline primesSeq() = ...
let primesintSeq = primesSeq() //if you use this as an int seq later the compiler will figure it out, otherwise you use
let specified : int seq = primesSeq()
I am not so sure about the sqrt case though - it probably depends on how hacky you are willing to make the solution.
A naïve implementation of generic sqRoot may go along these lines:
let sqRoot arg =
let inline sqrtd a = (double >> sqrt) a
let result = match box(arg) with
| :? int64 as i -> (sqrtd i) |> int64 |> box
| :? int as i -> (sqrtd i) |> int |> box
// cases for other relevant integral types
| _ -> failwith "Unsupported type"
unbox result
and then, checking in FSI:
> let result: int = sqRoot 4;;
val result : int = 2
> let result: int64 = sqRoot 9L;;
val result : int64 = 3L
Related
I created a generator to generate lists of int with the same lenght and to test the property of zip and unzip.
Running the test I get once in a while the error
Error: System.ArgumentException: list2 is 1 element shorter than list1
but it shouldn't happen because of my generator.
I got three times the test 100% passed and then the error above. Why?
It seems my generator is not working properly.
let samelength (x, y) =
List.length x = List.length y
let arbMyGen2 = Arb.filter samelength Arb.from<int list * int list>
type MyGenZ =
static member genZip() =
{
new Arbitrary<int list * int list>() with
override x.Generator = arbMyGen2 |> Arb.toGen
override x.Shrinker t = Seq.empty
}
let _ = Arb.register<MyGenZ>()
let pro_zip (xs: int list, ys: int list) =
(xs, ys) = List.unzip(List.zip xs ys)
|> Prop.collect (List.length xs = List.length ys)
do Check.Quick pro_zip
Your code, as written, works for me. So I'm not sure what exactly is wrong, but I can give you a few helpful (hopefully!) hints.
In the first instance, try not using the registrating mechanism, but instead using Prop.forAll, as follows:
let pro_zip =
Prop.forAll arbMyGen2 (fun (xs,ys) ->
(xs, ys) = List.unzip(List.zip xs ys)
|> Prop.collect (List.length xs))
do Check.Quick pro_zip
Note I've also changed your Prop.collect call to collect the length of the list(s), which gives somewhat more interesting output. In fact your property already checks that the lists are the same length (albeit implicitly) so the test will fail with a counterexample if they are not.
Arb.filter transforms an existing Arbitrary (i.e. generator and filter) to a new Arbitrary. In other words, arbMyGen2 has a shrinking function that'll work (i.e. only returns smaller pairs of lists that are of equal length), while in genZip() you throw the shrinker away. It would be fine to simply write
type MyGenZ =
static member genZip() = arbMyGen2
instead.
I was reading Idris tutorial. And I can't understand the following code.
disjoint : (n : Nat) -> Z = S n -> Void
disjoint n p = replace {P = disjointTy} p ()
where
disjointTy : Nat -> Type
disjointTy Z = ()
disjointTy (S k) = Void
So far, what I figure out is ...
Void is the empty type which is used to prove something is impossible.
replace : (x = y) -> P x -> P y
replace uses an equality proof to transform a predicate.
My questions are:
which one is an equality proof? (Z = S n)?
which one is a predicate? the disjointTy function?
What's the purpose of disjointTy? Does disjointTy Z = () means Z is in one Type "land" () and (S k) is in another land Void?
In what way can an Void output represent contradiction?
Ps. What I know about proving is "all things are no matched then it is false." or "find one thing that is contradictory"...
which one is an equality proof? (Z = S n)?
The p parameter is the equality proof here. p has type Z = S n.
which one is a predicate? the disjointTy function?
Yes, you are right.
What's the purpose of disjointTy?
Let me repeat the definition of disjointTy here:
disjointTy : Nat -> Type
disjointTy Z = ()
disjointTy (S k) = Void
The purpose of disjointTy is to be that predicate replace function needs. This consideration determines the type of disjointTy, viz. [domain] -> Type. Since we have equality between naturals numbers, [domain] is Nat.
To understand how the body has been constructed we need to take a look at replace one more time:
replace : (x = y) -> P x -> P y
Recall that we have p of Z = S n, so x from the above type is Z and y is S n. To call replace we need to construct a term of type P x, i.e. P Z in our case. This means the type P Z returns must be easily constructible, e.g. the unit type is the ideal candidate for this. We have justified disjointTy Z = () clause of the definition of disjointTy. Of course it's not the only option, we could have used any other inhabited (non-empty) type, like Bool or Nat, etc.
The return value in the second clause of disjointTy is obvious now -- we want replace to return a value of Void type, so P (S n) has to be Void.
Next, we use disjointTy like so:
replace {P = disjointTy} p ()
^ ^ ^
| | |
| | the value of `()` type
| |
| proof term of Z = S n
|
we are saying "this is the predicate"
As a bonus, here is an alternative proof:
disjoint : (n : Nat) -> Z = S n -> Void
disjoint n p = replace {P = disjointTy} p False
where
disjointTy : Nat -> Type
disjointTy Z = Bool
disjointTy (S k) = Void
I have used False, but could have used True -- it doesn't matter. What matters is our ability to construct a term of type disjointTy Z.
In what way can an Void output represent contradiction?
Void is defined like so:
data Void : Type where
It has no constructors! There is no way to create a term of this type whatsoever (under some conditions: like Idris' implementation is correct and the underlying logic of Idris is sane, etc.). So if some function claims it can return a term of type Void there must be something fishy going on. Our function says: if you give me a proof of Z = S n, I will return a term of the empty type. This means Z = S n cannot be constructed in the first place because it leads to a contradiction.
Yes, p : x = y is an equality proof. So p is a equality proof and Z = S k is a equality type.
Also yes, usually any P : a -> Type is called predicate, like IsSucc : Nat -> Type. In boolean logic, a predicate would map Nat to true or false. Here, a predicate holds, if we can construct a proof for it. And it is true, if we can construct it (prf : ItIsSucc 4). And it is false, if we cannot construct it (there is no member of ItIsSucc Z).
At the end, we want Void. Read the replace call as Z = S k -> disjointTy Z -> disjointTy (S k), that is Z = S K -> () -> Void. So replace needs two arguments: the proof p : Z = S k and the unit () : (), and voilà, we have a void. By the way, instead of () you could use any type that you can construct, e.g. disjointTy Z = Nat and then use Z instead of ().
In dependent type theory we construct proofs like prf : IsSucc 4. We would say, we have a proof prf that IsSucc 4 is true. prf is also called a witness for IsSucc 4. But with this alone we could only proove things to be true. This is the definiton for Void:
data Void : Type where
There is no constructor. So we cannot construct a witness that Void holds. If you somehow ended up with a prf : Void, something is wrong and you have a contradiction.
I'm working on a function that takes two arguments: a match value and a list of tuples. The goal is to match the first value (a string) in each tuple against the match value (also a string) and add the second value (an int) in those matching tuples to a new list, which is returned in sorted order. I started out with:
let getElems strMatch tupList =
let rec loop acc = function
| [] -> acc
| hd :: tl ->
match hd with
| (strMatch, v) -> loop (v :: acc) tl
| _ -> loop (acc) tl
List.sort (loop [] tupList)
...but came to realize that strMatch is out of scope as a pattern match so the second rule would never get matched. So I started trying to pass strMatch to the inner code blocks like so:
let getElems strMatch tupList =
let rec loop strMatch acc tupList =
match tupList with
| [] -> acc
| hd :: tl ->
match hd with
| (strMatch, v) -> loop strMatch (v :: acc) tl
| _ -> loop strMatch (acc) tl
List.sort (loop strMatch [] tupList)
...but the value is still out of scope in the match blocks. I suppose it would be possible to pass strMatch into those blocks but this seems messy and I'm wondering if there is a more elegant way.
EDIT: So here are my results...
First, I get the warning "This rule will never be matched." When I run the function as-is:
getElems "A" [("A",5);("BB",6);("AA",9);("A",0)];;
> val it : int list = [0; 5; 6; 9]
But if I hard code strMatch as "A" in the function:
getElems "A" [("A",5);("BB",6);("AA",9);("A",0)];;
> val it : int list = [0; 5]
Which is what is desired. But I'm required to take any match as an argument.
So I've decided to give F# a try and ported one the algorithms I've written in C# to it. At one point, I have noticed that debug build run faster than the release one. I then played with the optimization settings and got these results:
The times show the total execution time of the algorithm over 100000 runs. I am using the F# compiler that comes with Visual Studio 2010 SP1. Target platform is Any CPU.
Opt off, tail calls off: 5.81s
Opt off, tail calls on : 5.79s
Opt on , tail calls off: 6.48s
Opt on , tail calls on : 6.40s
I am really puzzled by this - why does the optimization make the code run slower? The C# version of the algorithm does not exhibit this behavior (altho it is implemented in a slightly different way)
Here is a stripped down version of the F# code, it is an algorithm that finds patterns in molecules. All the code that this F# program relies on is written in F#.
namespace Motives
module Internal =
type Motive =
{ ResidueSet: Set<Residue>; AtomSet: Set<IAtom> }
member this.Atoms : IAtom seq =
seq {
for r in this.ResidueSet do yield! r.Atoms
yield! this.AtomSet
}
static member fromResidues (residues : Residue seq) = residues |> Seq.fold (fun (m: Set<Residue>) r -> m.Add(r)) Set.empty |> fun rs -> { ResidueSet = rs; AtomSet = Set.empty }
static member fromAtoms (atoms : IAtom seq) = atoms |> Seq.fold (fun (m: Set<IAtom>) a -> m.Add(a)) Set.empty |> fun atoms -> { ResidueSet = Set.empty; AtomSet = atoms }
static member merge (m1: Motive) (m2: Motive) = { ResidueSet = Set.union m1.ResidueSet m2.ResidueSet; AtomSet = Set.union m1.AtomSet m2.AtomSet }
static member distance (m1: Motive) (m2: Motive) = Seq.min (seq { for a in m1.Atoms do for b in m2.Atoms -> a.Position.DistanceTo(b.Position) })
type Structure with
static member fromMotive (m: Motive) (parent: IStructure) (addBonds: bool) : IStructure =
let atoms = AtomCollection.FromUniqueAtoms(m.Atoms)
let bonds =
match addBonds with
| true -> BondCollection.Create(atoms |> Seq.map (fun a -> parent.Bonds.[a]) |> Seq.concat)
| _ -> BondCollection.Empty
Structure.Create (parent.Id + "_" + atoms.[0].Id.ToString(), atoms, bonds)
// KDTree used for range queries
// AminoChains used for regex queries
type StructureContext =
{ Structure: IStructure; KDTree: Lazy<KDAtomTree>; AminoChains: Lazy<(Residue array * string) list> }
static member create (structure: IStructure) =
match structure.IsPdbStructure() with
| false -> { Structure = structure; KDTree = Lazy.Create(fun () -> structure.Atoms.ToKDTree()); AminoChains = Lazy.CreateFromValue([]) }
| true ->
let aminoChains = new System.Func<(Residue array * string) list> (fun () ->
let residues = structure.PdbResidues() |> Seq.filter (fun r -> r.IsAmino)
residues
|> Seq.groupBy (fun r -> r.ChainIdentifier)
|> Seq.map (fun (k,rs) -> rs |> Array.ofSeq, String.concat "" (rs |> Seq.map (fun r -> r.ShortName)))
|> List.ofSeq)
{ Structure = structure; KDTree = Lazy.Create(fun () -> structure.Atoms.ToKDTree()); AminoChains = Lazy.Create(aminoChains) }
// Remember the named motives from named patterns
type MatchContext =
{ StructureContext: StructureContext; NamedMotives: Map<string, Motive> }
static member merge (c1: MatchContext) (c2: MatchContext) =
{ StructureContext = c1.StructureContext; NamedMotives = c2.NamedMotives |> Map.fold (fun m k v -> m.Add(k,v)) c1.NamedMotives }
type MatchedMotive = Motive * MatchContext
type Pattern =
| EmptyPattern
| GeneratingPattern of ( StructureContext -> MatchedMotive seq )
| ConstraintPattern of ( MatchedMotive -> MatchedMotive option ) * Pattern
static member matches (p: Pattern) (context: StructureContext) : MatchedMotive seq =
match p with
| GeneratingPattern generator -> generator context
| ConstraintPattern (transform, pattern) ->
Pattern.matches pattern context
|> Seq.choose (fun m -> transform m)
| _ -> Seq.empty
let ringPattern (names: string list) =
let fingerprint =
names
|> Seq.map (fun s -> ElementSymbol.Create(s).ToString())
|> Seq.sort
|> String.concat ""
let generator (context: StructureContext) =
let rings = context.Structure.Rings().GetRingsByFingerprint(fingerprint)
rings |> Seq.map (fun r -> Motive.fromAtoms r.Atoms, { StructureContext = context; NamedMotives = Map.empty })
GeneratingPattern generator
open Internal
type MotiveFinder (pattern: string) =
// I am using a hard coded pattern here for testing purposes
let pattern = ringPattern ["C"; "C"; "C"; "C"; "C"; "O"]
member this.Matches (structure: IStructure) =
Pattern.matches pattern (StructureContext.create structure)
|> Seq.map (fun (m, mc) -> Structure.fromMotive m mc.StructureContext.Structure false)
|> List.ofSeq
|> List.sortBy (fun s -> s.Atoms.[0].Id)
///////////////////////////////////////////////////////////////////
// performance test
let warmUp = (new MotiveFinder("")).Matches (StructureReader.ReadPdb(filename, computeBonds = true))
printfn "%i" (List.length warmUp)
let structure = StructureReader.ReadPdb(filename, computeBonds = true)
let stopWatch = System.Diagnostics.Stopwatch.StartNew()
let nruns = 100000
let result =
seq {
for i in 1 .. nruns do
yield (new MotiveFinder("")).Matches structure
} |> Seq.nth (nruns-1)
stopWatch.Stop()
printfn "Time elapsed: %f seconds" stopWatch.Elapsed.TotalSeconds
EDIT2:
I seem to have narrowed down the problem to the implementation of the Set type.
For this code:
let stopWatch = System.Diagnostics.Stopwatch.StartNew()
let runs = 1000000
let result =
seq {
for i in 1 .. runs do
let setA = [ 1 .. (i % 10) + 5 ] |> Set.ofList
let setB = [ 1 .. (i % 10) + 5 ] |> Set.ofList
yield Set.union setA setB
} |> Seq.nth (runs - 1)
stopWatch.Stop()
printfn "Time elapsed: %f seconds" stopWatch.Elapsed.TotalSeconds
printfn "%A" result
I get ~7.5s with optimization off and ~8.0s with optimization on. Still target = Any CPU (and I have i7-860 processor).
EDIT3:
And right after I posted the previous edit I figured I should try it on lists only.
So for
let stopWatch = System.Diagnostics.Stopwatch.StartNew()
let runs = 1000000
let result1 =
seq {
for i in 1 .. runs do
let list = [ 1 .. i % 100 + 5 ]
yield list
} |> Seq.nth (runs - 1)
stopWatch.Stop()
printfn "Time elapsed: %f seconds" stopWatch.Elapsed.TotalSeconds
printfn "%A" result1
I get ~3s with opt. off and ~3.5s with opt. on.
EDIT4:
If I remove the seq builder and just do
let stopWatch = System.Diagnostics.Stopwatch.StartNew()
let runs = 1000000
let mutable ret : int list = []
for i in 1 .. runs do
let list = [ 1 .. i % 100 + 5 ]
ret <- list
stopWatch1.Stop()
printfn "Time elapsed: %f seconds" stopWatch.Elapsed.TotalSeconds
printfn "%A" ret
I get ~3s with optimization both on and off. So it seem that the problem is somewhere in optimizing the seq builder code.
Strangely enough, I wrote a test app in C#:
var watch = Stopwatch.StartNew();
int runs = 1000000;
var result = Enumerable.Range(1, runs)
.Select(i => Microsoft.FSharp.Collections.ListModule.OfSeq(Enumerable.Range(1, i % 100 + 5)))
.ElementAt(runs - 1);
watch.Stop();
Console.WriteLine(result);
Console.WriteLine("Time: {0}s", watch.Elapsed.TotalSeconds);
And the code happens to run almost twice as fast as the F# solution at ~1.7s.
EDIT5:
Based on the discussion with Jon Harrop I have found out the thing that is causing the optimized code run slower (I still don't know why tho).
If I change Motive.Atoms from
member this.Atoms : IAtom seq =
seq {
for r in this.ResidueSet do yield! r.Atoms
yield! this.AtomSet
}
to
member this.Atoms : IAtom seq =
Seq.append (this.ResidueSet |> Seq.collect (fun r -> r.Atoms)) this.AtomSet
then the program runs ~7.1s in both optimized and non-optimized version. Which is slower than the seq version, but at least consistent.
So it seems that the F# compiler just can't optimize computation expressions and actually makes them slower by trying so.
I can also observe your wrapper code and penultimate example running slightly slower with optimizations enabled but the difference is less than 10% and, although anomalous, I am not surprised that optimizations can sometimes slightly degrade performance.
I should note that your style of coding leaves a lot of room for optimization but without the entire source code it is not possible for me to help optimize it. Your example uses the following code:
let result1 =
seq {
for i in 1 .. runs do
let list = [ 1 .. i % 100 + 5 ]
yield list
} |> Seq.nth (runs - 1)
when this is shorter, more idiomatic and orders of magnitude faster:
let result1 =
Seq.init runs (fun i -> List.init ((i+1) % 100 + 5) ((+) 1))
|> Seq.nth (runs - 1)
EDIT
In your comments below you say that you want to execute the function argument in which case I would not assume that Seq.nth will do this for you so I would use a for loop instead:
let mutable list = []
for i=1 to runs do
list <- List.init (i % 100 + 5) ((+) 1)
list
This is still 9× faster than the original.
I'm trying to translate the Haskell core library's Arrows into F# (I think it's a good exercise to understanding Arrows and F# better, and I might be able to use them in a project I'm working on.) However, a direct translation isn't possible due to the difference in paradigms. Haskell uses type-classes to express this stuff, but I'm not sure what F# constructs best map the functionality of type-classes with the idioms of F#. I have a few thoughts, but figured it best to bring it up here and see what was considered to be the closest in functionality.
For the tl;dr crowd: How do I translate type-classes (a Haskell idiom) into F# idiomatic code?
For those accepting of my long explanation:
This code from the Haskell standard lib is an example of what I'm trying to translate:
class Category cat where
id :: cat a a
comp :: cat a b -> cat b c -> cat a c
class Category a => Arrow a where
arr :: (b -> c) -> a b c
first :: a b c -> a (b,d) (c,d)
instance Category (->) where
id f = f
instance Arrow (->) where
arr f = f
first f = f *** id
Attempt 1: Modules, Simple Types, Let Bindings
My first shot at this was to simply map things over directly using Modules for organization, like:
type Arrow<'a,'b> = Arrow of ('a -> 'b)
let arr f = Arrow f
let first f = //some code that does the first op
That works, but it loses out on polymorphism, since I don't implement Categories and can't easily implement more specialized Arrows.
Attempt 1a: Refining using Signatures and types
One way to correct some issues with Attempt 1 is to use a .fsi file to define the methods (so the types enforce easier) and to use some simple type tweaks to specialize.
type ListArrow<'a,'b> = Arrow<['a],['b]>
//or
type ListArrow<'a,'b> = LA of Arrow<['a],['b]>
But the fsi file can't be reused (to enforce the types of the let bound functions) for other implementations, and the type renaming/encapsulating stuff is tricky.
Attempt 2: Object models and interfaces
Rationalizing that F# is built to be OO also, maybe a type hierarchy is the right way to do this.
type IArrow<'a,'b> =
abstract member comp : IArrow<'b,'c> -> IArrow<'a,'c>
type Arrow<'a,'b>(func:'a->'b) =
interface IArrow<'a,'b> with
member this.comp = //fun code involving "Arrow (fun x-> workOn x) :> IArrow"
Aside from how much of a pain it can be to get what should be static methods (like comp and other operators) to act like instance methods, there's also the need to explicitly upcast the results. I'm also not sure that this methodology is still capturing the full expressiveness of type-class polymorphism. It also makes it hard to use things that MUST be static methods.
Attempt 2a: Refining using type extensions
So one more potential refinement is to declare the interfaces as bare as possible, then use extension methods to add functionality to all implementing types.
type IArrow<'a,'b> with
static member (&&&) f = //code to do the fanout operation
Ah, but this locks me into using one method for all types of IArrow. If I wanted a slightly different (&&&) for ListArrows, what can I do? I haven't tried this method yet, but I would guess I can shadow the (&&&), or at least provide a more specialized version, but I feel like I can't enforce the use of the correct variant.
Help me
So what am I supposed to do here? I feel like OO should be powerful enough to replace type-classes, but I can't seem to figure out how to make that happen in F#. Were any of my attempts close? Are any of them "as good as it gets" and that'll have to be good enough?
My brief answer is:
OO is not powerful enough to replace type classes.
The most straightforward translation is to pass a dictionary of operations, as in one typical typeclass implementation. That is if typeclass Foo defines three methods, then define a class/record type named Foo, and then change functions of
Foo a => yadda -> yadda -> yadda
to functions like
Foo -> yadda -> yadda -> yadda
and at each call site you know the concrete 'instance' to pass based on the type at the call-site.
Here's a short example of what I mean:
// typeclass
type Showable<'a> = { show : 'a -> unit; showPretty : 'a -> unit } //'
// instances
let IntShowable =
{ show = printfn "%d"; showPretty = (fun i -> printfn "pretty %d" i) }
let StringShowable =
{ show = printfn "%s"; showPretty = (fun s -> printfn "<<%s>>" s) }
// function using typeclass constraint
// Showable a => [a] -> ()
let ShowAllPretty (s:Showable<'a>) l = //'
l |> List.iter s.showPretty
// callsites
ShowAllPretty IntShowable [1;2;3]
ShowAllPretty StringShowable ["foo";"bar"]
See also
https://web.archive.org/web/20081017141728/http://blog.matthewdoig.com/?p=112
Here's the approach I use to simulate Typeclasses (from http://code.google.com/p/fsharp-typeclasses/ ).
In your case, for Arrows could be something like this:
let inline i2 (a:^a,b:^b ) =
((^a or ^b ) : (static member instance: ^a* ^b -> _) (a,b ))
let inline i3 (a:^a,b:^b,c:^c) =
((^a or ^b or ^c) : (static member instance: ^a* ^b* ^c -> _) (a,b,c))
type T = T with
static member inline instance (a:'a ) =
fun x -> i2(a , Unchecked.defaultof<'r>) x :'r
static member inline instance (a:'a, b:'b) =
fun x -> i3(a, b, Unchecked.defaultof<'r>) x :'r
type Return = Return with
static member instance (_Monad:Return, _:option<'a>) = fun x -> Some x
static member instance (_Monad:Return, _:list<'a> ) = fun x -> [x]
static member instance (_Monad:Return, _: 'r -> 'a ) = fun x _ -> x
let inline return' x = T.instance Return x
type Bind = Bind with
static member instance (_Monad:Bind, x:option<_>, _:option<'b>) = fun f ->
Option.bind f x
static member instance (_Monad:Bind, x:list<_> , _:list<'b> ) = fun f ->
List.collect f x
static member instance (_Monad:Bind, f:'r->'a, _:'r->'b) = fun k r -> k (f r) r
let inline (>>=) x (f:_->'R) : 'R = T.instance (Bind, x) f
let inline (>=>) f g x = f x >>= g
type Kleisli<'a, 'm> = Kleisli of ('a -> 'm)
let runKleisli (Kleisli f) = f
type Id = Id with
static member instance (_Category:Id, _: 'r -> 'r ) = fun () -> id
static member inline instance (_Category:Id, _:Kleisli<'a,'b>) = fun () ->
Kleisli return'
let inline id'() = T.instance Id ()
type Comp = Comp with
static member instance (_Category:Comp, f, _) = (<<) f
static member inline instance (_Category:Comp, Kleisli f, _) =
fun (Kleisli g) -> Kleisli (g >=> f)
let inline (<<<) f g = T.instance (Comp, f) g
let inline (>>>) g f = T.instance (Comp, f) g
type Arr = Arr with
static member instance (_Arrow:Arr, _: _ -> _) = fun (f:_->_) -> f
static member inline instance (_Arrow:Arr, _:Kleisli<_,_>) =
fun f -> Kleisli (return' <<< f)
let inline arr f = T.instance Arr f
type First = First with
static member instance (_Arrow:First, f, _: 'a -> 'b) =
fun () (x,y) -> (f x, y)
static member inline instance (_Arrow:First, Kleisli f, _:Kleisli<_,_>) =
fun () -> Kleisli (fun (b,d) -> f b >>= fun c -> return' (c,d))
let inline first f = T.instance (First, f) ()
let inline second f = let swap (x,y) = (y,x) in arr swap >>> first f >>> arr swap
let inline ( *** ) f g = first f >>> second g
let inline ( &&& ) f g = arr (fun b -> (b,b)) >>> f *** g
Usage:
> let f = Kleisli (fun y -> [y;y*2;y*3]) <<< Kleisli ( fun x -> [ x + 3 ; x * 2 ] ) ;;
val f : Kleisli<int,int list> = Kleisli <fun:f#4-14>
> runKleisli f <| 5 ;;
val it : int list = [8; 16; 24; 10; 20; 30]
> (arr (fun y -> [y;y*2;y*3])) 3 ;;
val it : int list = [3; 6; 9]
> let (x:option<_>) = runKleisli (arr (fun y -> [y;y*2;y*3])) 2 ;;
val x : int list option = Some [2; 4; 6]
> ( (*) 100) *** ((+) 9) <| (5,10) ;;
val it : int * int = (500, 19)
> ( (*) 100) &&& ((+) 9) <| 5 ;;
val it : int * int = (500, 14)
> let x:List<_> = (runKleisli (id'())) 5 ;;
val x : List<int> = [5]
Note: use id'() instead of id
Update: you need F# 3.0 to compile this code, otherwise here's the F# 2.0 version.
And here's a detailed explanation of this technique which is type-safe, extensible and as you can see works even with some Higher Kind Typeclasses.