Last active
February 27, 2021 11:56
-
-
Save CarstenKoenig/8f7574e02049a0ec6715 to your computer and use it in GitHub Desktop.
Reader monad in F#
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
namespace ReaderM | |
type ReaderM<'d,'out> = | |
'd -> 'out | |
module Reader = | |
// basic operations | |
let run dep (rm : ReaderM<_,_>) = | |
rm dep | |
let constant (c : 'c) : ReaderM<_,'c> = | |
fun _ -> c | |
// lifting of functions and state | |
let lift1 (f : 'd -> 'a -> 'out) | |
: 'a -> ReaderM<'d, 'out> = | |
fun a dep -> f dep a | |
let lift2 (f : 'd -> 'a -> 'b -> 'out) | |
: 'a -> 'b -> ReaderM<'d, 'out> = | |
fun a b dep -> f dep a b | |
let lift3 (f : 'd -> 'a -> 'b -> 'c -> 'out) | |
: 'a -> 'b -> 'c -> ReaderM<'d, 'out> = | |
fun a b c dep -> f dep a b c | |
let liftDep (proj : 'd2 -> 'd1) | |
(rm : ReaderM<'d1, 'output>) | |
: ReaderM<'d2, 'output> = | |
proj >> rm | |
// functor | |
let fmap (f : 'a -> 'b) | |
(g : 'c -> 'a) | |
: ('c -> 'b) = | |
g >> f | |
let map (f : 'a -> 'b) | |
(rm : ReaderM<'d, 'a>) | |
: ReaderM<'d,'b> = | |
rm >> f | |
let (<?>) = map | |
// applicative-functor | |
let apply (f : ReaderM<'d, 'a->'b>) | |
(rm : ReaderM<'d, 'a>) | |
: ReaderM<'d, 'b> = | |
fun dep -> | |
let f' = run dep f | |
let a = run dep rm | |
f' a | |
let (<*>) = apply | |
// monad | |
let bind (rm : ReaderM<'d, 'a>) | |
(f : 'a -> ReaderM<'d,'b>) | |
: ReaderM<'d, 'b> = | |
fun dep -> | |
f (rm dep) | |
|> run dep | |
let (>>=) = bind | |
type ReaderMBuilder internal () = | |
member __.Bind(m, f) = m >>= f | |
member __.Return(v) = constant v | |
member __.ReturnFrom(v) = v | |
member __.Delay(f) = f () | |
let Do = ReaderMBuilder() | |
module Example = | |
open Reader | |
type IResources = | |
abstract GetString : unit -> string | |
let resource = | |
{ new IResources with | |
member __.GetString () = "World" | |
} | |
type IOutput = | |
abstract Print : string -> unit | |
let output = | |
{ new IOutput with | |
member __.Print s = printfn "%s" s | |
} | |
type Dependencies = IResources * IOutput | |
let depig = (resource, output) | |
let getWord = | |
lift1 (fun (res : IResources) -> res.GetString) () | |
let print = | |
lift1 (fun (out : IOutput) -> out.Print) | |
let computation = Do { | |
let! text = sprintf "Hello %s" <?> liftDep fst getWord | |
do! liftDep snd (print text) | |
} | |
// sadly we have to make it into a function - value restriction :( | |
let computation2 = | |
sprintf "Hello %s" <?> liftDep fst getWord | |
>>= fmap (liftDep snd) print | |
let test() = | |
run depig computation | |
let test2() = | |
run depig computation2 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Can you elaborate the comments "sadly we have to make it into a function - value restriction"?