Source file monad.ml

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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
open Module_types


module type SIG_MIN =
  sig
    type _ t
    val return: 'a -> 'a t
    val (>>=): 'a t -> ('a -> 'b t) -> 'b t
  end

module type SIG_WITH_MAP =
  sig
    include SIG_MIN
    val map: ('a -> 'b) -> 'a t -> 'b t
  end





module type RESULT =
  sig
    include MONAD
    type error
    val throw: error -> 'a t
    val catch: 'a t -> (error -> 'a t) -> 'a t
    val continue: 'a t -> ('a -> 'z) -> (error -> 'z) -> 'z
  end




module Of_sig_with_map (M:SIG_WITH_MAP): MONAD with type 'a t = 'a M.t =
  struct
    include M

    let (>=>) f g a =
      f a >>= g

    let (<*>) mf m =
      mf >>= fun f -> map f m

    let join mm =
      mm >>= fun m -> m
  end


module Of_sig_min (M:SIG_MIN): MONAD with type 'a t = 'a M.t =
  struct
    include M

    let (>=>) f g a =
      f a >>= g

    let map (f:'a -> 'b) (m:'a t): 'b t =
      m >>= fun a -> return (f a)

    let (<*>) mf m =
      mf >>= fun f -> map f m

    let join mm =
      mm >>= fun m -> m
  end




module Identity =
struct
    include
        Of_sig_min (
        struct
            type 'a t = 'a
            let return (a: 'a): 'a t = a
            let (>>=) (m: 'a t) (f: 'a -> 'b t): 'b t =
                f m
        end
        )
    let eval (m: 'a t): 'a =
        m
end




module Result (E: ANY) =
  struct
    type error = E.t

    include
      Of_sig_min(
          struct
            type 'a t = ('a,error) result
            let return (a:'a): 'a t = Ok a
            let (>>=) (m:'a t) (f:'a -> 'b t): 'b t =
              match m with
              | Ok a -> f a
              | Error e -> Error e
          end
        )

    let throw (e:error): 'a t =
      Error e

    let catch (m:'a t) (f:error->'a t): 'a t =
      match m with
      | Ok _ -> m
      | Error e -> f e

    let continue (m:'a t) (f1:'a->'r) (f2:error->'r): 'r =
      match m with
      | Ok a ->
         f1 a
      | Error e ->
         f2 e
  end (* Result *)