this repo has no description
patrick.sirref.org
1module type Applicative = sig
2 type 'a t
3
4 val return : 'a -> 'a t
5 val fmap : ('a -> 'b) -> 'a t -> 'b t
6 val mbind : ('a -> 'b t) -> 'a t -> 'b t
7 val apply : ('a -> 'b) t -> 'a t -> 'b t
8end
9
10module type Selective = sig
11 include Applicative
12
13 val select : ('a, 'b) Either.t t -> ('a -> 'b) t -> 'b t
14end
15
16module T (A : Applicative) = struct
17 let do_thing (a : _ A.t) (v : _ A.t) =
18 let v1 =
19 A.mbind
20 (fun i ->
21 if Random.int i < 5 then A.mbind (fun v -> A.return @@ v ^ "hello") v
22 else A.return "world")
23 a
24 in
25 let v2 =
26 A.fmap (fun i -> if Random.int i < 5 then "hello" else "world") a
27 in
28 (v1, v2)
29end
30
31module Make (S : Selective) = struct
32 include S
33
34 let ( <*? ) x f = S.select x f
35 let map ~f x = apply (return f) x
36
37 let branch x l r =
38 map x ~f:(Either.map ~left:Fun.id ~right:Either.left)
39 <*? map l ~f:(Fun.compose Either.right)
40 <*? r
41
42 let if' x t f =
43 branch
44 (map x ~f:(fun b -> if b then Either.Left () else Either.Right ()))
45 (map t ~f:Fun.const) (map f ~f:Fun.const)
46
47 let when' x act = if' x act (return ())
48 let ( <||> ) a b = if' a (return true) b
49 let ( <&&> ) a b = if' a b (return false)
50end
51
52module Shl (S : Selective) = struct
53 module Select = struct
54 include Make (S)
55 end
56
57 module Shelter = Shelter_main
58
59 type step =
60 | From : string -> step
61 | Run : string -> step
62 | Copy : string * string -> step
63 | Parallel : string list -> step
64
65 type 'a with_session = { session : string; step : 'a }
66 type 'a llist = Singleton of 'a | Cons of 'a * 'a llist
67
68 let rec map f = function
69 | Singleton v -> Singleton (f v)
70 | Cons (x, xs) -> Cons (f x, map f xs)
71
72 type t = step with_session llist
73
74 let from image =
75 Select.return (Singleton { session = "main"; step = From image })
76
77 let run cmd =
78 Select.return (function (Singleton prev | Cons (prev, _)) as l ->
79 Cons ({ prev with step = Run cmd }, l))
80
81 let copy ~src ~dst = Select.return (Copy (src, dst))
82
83 let session session =
84 Select.return (function (Singleton step | Cons (step, _)) as l ->
85 Cons ({ step with session }, l))
86
87 let with_session session = Select.return (map (fun v -> { v with session }))
88
89 let rec to_list = function
90 | Singleton v -> [ v ]
91 | Cons (x, xs) -> x :: to_list xs
92
93 let stdout _ = ""
94
95 let build steps =
96 Select.apply
97 (Select.return (fun steps ->
98 to_list steps |> List.rev
99 |> List.map (function
100 | { session; step = From from } ->
101 Printf.sprintf "(%s) FROM %s" session from
102 | { session; step = Run cmd } ->
103 Printf.sprintf "(%s) RUN %s" session cmd
104 | { session; step = Copy (src, dst) } ->
105 Printf.sprintf "(%s) COPY %s %s" session src dst
106 | _ -> assert false)
107 |> String.concat "\n"))
108 steps
109end
110
111module Identity = Make (struct
112 type 'a t = 'a
113
114 let return x = x
115 let apply f x = f x
116 let select e f = match e with Either.Left v -> f v | Either.Right b -> b
117end)
118
119module D = Shl (Identity)
120
121let dockerfile =
122 let open D in
123 let base_image = from "alpine" in
124 let is_node_lst img = String.equal "v22.15.0" (stdout img) in
125 let cmds base =
126 let node_version = run "node --version" base in
127 Select.if'
128 (Select.map ~f:is_node_lst node_version)
129 (run "node -e 'console.log('success!')")
130 (run "node -e 'console.log('failure!')")
131 base
132 in
133 with_session "node" (cmds base_image)
134
135let () = print_endline (D.build dockerfile)