package sugar

  1. Overview
  2. Docs

Source file strict_result_builder.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
open S.Params

(**
  How to create a {{!Sugar.S.Strict_result} strict result monad}:

  {[
  module MyError = struct
    type t = A | B | Unexpected of exn

    let panic e = Unexpected e
  end

  module MyResult = Sugar.Result.Make (MyError)
  ]}

  The generated module will have the signature of {!Sugar.S.Strict_result}
*)


(**
  A parametric module that implements the blocking interface.
*)
module Make (UserError:Strict_error) : S.Strict_result
  with type error = UserError.t =
struct
  type 'a result = ('a, UserError.t) Result.result
  type error = UserError.t

  let return v = Result.Ok v

  let throw e = Result.Error e

  let bind r f =
    match r with
      | Result.Error e -> Result.Error e
      | Result.Ok v ->
        ( try f v with
          e -> Result.Error (UserError.panic e)
        )

  let bind_unless r f =
    match r with
    | Result.Ok v -> Result.Ok v
    | Result.Error e ->
      ( try f e with
        | e -> Result.Error (UserError.panic e)
      )

  let map r f =
    match r with
    | Result.Error e -> Result.Error e
    | Result.Ok v ->
      ( try Result.Ok (f v) with
        | e -> Result.Error (UserError.panic e)
      )


  module Infix = struct
    let (>>=) = bind
    let (>>|) = map
    let (>>>) x y = bind x (fun _ -> Lazy.force y)
    let (>---------) = bind_unless

    let (<*>) f x =
      f
      >>= fun f' ->
      x
      >>= fun x' ->
      return (f' x')

    let (<$>) f x = map x f

    let (>>) x y = bind x (fun () -> Lazy.force y)
  end

  let unwrap = function
    | Result.Ok r -> r
    | Result.Error _ -> invalid_arg "Could not unwrap value from result"

  let unwrap_or f r =
    match r with
    | Result.Ok r -> r
    | Result.Error e -> f e

  let expect r msg =
    match r with
    | Result.Ok r -> r
    | Result.Error _ -> invalid_arg msg


  let (>>=) = bind

  module Monad : Monad
    with type 'a t := 'a result =
  struct
    type 'a t = 'a result

    let return = return
    let (>>=) = bind
  end

  module For (Strict_monad: Strict_monad) = struct
    include Strict_promise_builder.Make (UserError) (Strict_monad)
  end

  module NoExceptions = Result_builder.Make (UserError)
end