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