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
module RealWorld : sig                              
                                                    
  type   world = private World                      
  type α pure  = private Pure of α                  
  type α io    = world → (α pure * world)           
                                                    
  val bind : α io → β io → β io                     
  val lift : α io → (α pure → β io) → β io          
                                                    
  val ( >> )  : α io →           β io  → β io       
  val ( >>= ) : α io → (α pure → β io) → β io       
                                                    
  val unit : unit pure                              
                                                    
  val effect : (α → β) → α pure → β io              
  val eval   : unit io → (unit pure * world)        
                                                    
end                                                 
                                                    
  = struct                                          
                                                    
  type   world = World                              
  type α pure  = Pure of α                          
  type α io    = world → (α pure * world)           
                                                    
  let bind : α io → β io → β io =                   
    λ action1 action2 world0 →                      
      let (a,world1) = action1 world0 in            
      let (b,world2) = action2 world1 in            
      (b,world2)                                    
                                                    
  let lift : α io → (α pure → β io) → β io =        
    λ action1 action2 world0 →                      
      let (a,world1) = action1   world0 in          
      let (b,world2) = action2 a world1 in          
      (b,world2)                                    
                                                    
  let ( >> )  : α io →           β io  → β io = bind
  let ( >>= ) : α io → (α pure → β io) → β io = lift
                                                    
  let unit : unit pure = Pure ()                    
                                                    
  let effect : (α → β) → α pure → β io =            
    λ f (Pure a) →                                  
      λ world → Pure (f a), world                   
                                                    
  let eval : unit io → (unit pure * world) =        
    λ main → main World                             
                                                    
end 

module RealWorld :
  sig
    type world = private World
    type 'a pure = private Pure of 'a
    type 'a io = world -> 'a pure * world
    val bind    : 'a io -> 'b io -> 'b io
    val lift    : 'a io -> ('a pure -> 'b io) -> 'b io
    val ( >> )  : 'a io -> 'b io -> 'b io
    val ( >>= ) : 'a io -> ('a pure -> 'b io) -> 'b io
    val unit    : unit pure
    val effect  : ('a -> 'b) -> 'a pure -> 'b io
    val eval    : unit io -> unit pure * world
  end

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
module Util = struct                                
                                                    
  open RealWorld                                    
                                                    
  let (!) : α → α io =                              
    λ a → effect (λ _ → a) unit                     
                                                    
  let readLn : string io =                          
    effect read_line unit                           
                                                    
  let putStr : string pure → unit io =              
    effect print_string                             
                                                    
  let putStrLn : string pure → unit io =            
    effect print_endline              	              
                                                    
  let sample : unit io =                            
    ! "What is your name?"                          
    >>= putStrLn                                    
    >>  readLn                                      
    >>= λ a →                                       
      ! "How old are you?"                          
      >>= putStrLn                                  
      >>  readLn                                    
      >>= λ b →                                     
        putStr a                                    
        >>  ! ": "                                  
        >>= putStr                                  
        >>  putStrLn b                              
                                                    
end                                                 

module Util :
  sig
    val ( ! )    : 'a -> 'a RealWorld.io
    val readLn   : string RealWorld.io
    val putStr   : string RealWorld.pure -> unit RealWorld.io
    val putStrLn : string RealWorld.pure -> unit RealWorld.io
    val sample   : unit RealWorld.io
  end

let _ = Util.sample |> RealWorld.eval 

mon@razerRamon:~/tmp/ocaml$ ocaml real_world.ml

What is your name?
John Doe
How old are you?
42
John Doe: 42