package primavera

  1. Overview
  2. Docs

Source file primavera.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
module Req = Sig.Req

module Make = struct
  module S1 (T : Req.S1) = struct
    type 'a output = 'a T.t
    type ('a, 'handler) t = 'handler -> 'a output

    let run ~handler program input = (program input) handler
    let perform program = program
    let return x _ = T.return x
    let map f handler x = T.map f (handler x)
    let apply fs handler x = T.apply (fs x) (handler x)
    let bind handler f x = T.bind (handler x) (fun a -> (f a) x)
    let replace x xs = map (fun _ -> x) xs
    let ignore x = replace () x
    let zip a b = apply (map (fun a b -> a, b) a) b
    let map2 f a b = apply (map f a) b
    let map3 f a b c = apply (map2 f a b) c
    let map4 f a b c d = apply (map3 f a b c) d
    let map5 f a b c d e = apply (map4 f a b c d) e
    let join m = bind m (fun x -> x)
    let compose g f x = bind (f x) (fun r -> g r)

    module Infix = struct
      let ( <$> ) = map
      let ( <$ ) = replace
      let ( $> ) m x = replace x m
      let ( <*> ) = apply
      let ( <&> ) = zip
      let ( <* ) a b = map2 Fun.const a b
      let ( *> ) a b = map2 (fun _ x -> x) a b
      let ( >>= ) = bind
      let ( =<< ) f m = bind m f
      let ( <=< ) = compose
      let ( >=> ) f g = compose g f
      let ( >> ) ma mb = ma >>= Fun.const mb
      let ( << ) ma _ = ma
    end

    module Syntax = struct
      let ( let+ ) x f = map f x
      let ( and+ ) = zip
      let ( and* ) = zip
      let ( let* ) = bind
    end

    include Infix
    include Syntax
  end

  module S2 (T : Req.S2) = struct
    type ('a, 'b) output = ('a, 'b) T.t
    type ('a, 'b, 'handler) t = 'handler -> ('a, 'b) output

    let run ~handler program input = (program input) handler
    let perform program = program
    let return x _ = T.return x
    let map f handler x = T.map f (handler x)
    let apply fs handler x = T.apply (fs x) (handler x)
    let bind handler f x = T.bind (handler x) (fun a -> (f a) x)
    let replace x xs = map (fun _ -> x) xs
    let ignore x = replace () x
    let zip a b = apply (map (fun a b -> a, b) a) b
    let map2 f a b = apply (map f a) b
    let map3 f a b c = apply (map2 f a b) c
    let map4 f a b c d = apply (map3 f a b c) d
    let map5 f a b c d e = apply (map4 f a b c d) e
    let join m = bind m (fun x -> x)
    let compose g f x = bind (f x) (fun r -> g r)

    module Infix = struct
      let ( <$> ) = map
      let ( <$ ) = replace
      let ( $> ) m x = replace x m
      let ( <*> ) = apply
      let ( <&> ) = zip
      let ( <* ) a b = map2 Fun.const a b
      let ( *> ) a b = map2 (fun _ x -> x) a b
      let ( >>= ) = bind
      let ( =<< ) f m = bind m f
      let ( <=< ) = compose
      let ( >=> ) f g = compose g f
      let ( >> ) ma mb = ma >>= Fun.const mb
      let ( << ) ma _ = ma
    end

    module Syntax = struct
      let ( let+ ) x f = map f x
      let ( and+ ) = zip
      let ( and* ) = zip
      let ( let* ) = bind
    end

    include Infix
    include Syntax
  end
end

module Id = struct
  type 'a t = 'a

  let return x = x
  let map f = f
  let apply f = f
  let bind x f = f x
end

include Make.S1 (Id)