+3

attic/dune

··· 1 1 + ; (executables 2 2 + ; (names main task) 3 3 + ; (libraries base eio_posix shelter.main))

+129

attic/main.ml

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

+106

attic/task.ml

··· 1 1 + (* Work in progress, prototyped in https://try.ocamlpro.com/. To be modified 2 2 + for Base. *) 3 3 + 4 4 + module type Applicative = sig 5 5 + type 'a t 6 6 + 7 7 + val return : 'a -> 'a t 8 8 + val apply : ('a -> 'b) t -> 'a t -> 'b t 9 9 + end 10 10 + 11 11 + module type Selective = sig 12 12 + include Applicative 13 13 + 14 14 + val select : ('a, 'b) Either.t t -> ('a -> 'b) t -> 'b t 15 15 + end 16 16 + 17 17 + module Make (S : Selective) = struct 18 18 + include S 19 19 + 20 20 + let ( <*? ) x f = S.select x f 21 21 + let map ~f x = apply (return f) x 22 22 + 23 23 + let branch x l r = 24 24 + map x ~f:(Either.map ~left:Fun.id ~right:Either.left) 25 25 + <*? map l ~f:(Fun.compose Either.right) 26 26 + <*? r 27 27 + 28 28 + let if' x t f = 29 29 + branch 30 30 + (map x ~f:(fun b -> if b then Either.Left () else Either.Right ())) 31 31 + (map t ~f:Fun.const) (map f ~f:Fun.const) 32 32 + 33 33 + let when' x act = if' x act (return ()) 34 34 + let ( <||> ) a b = if' a (return true) b 35 35 + let ( <&&> ) a b = if' a b (return false) 36 36 + end 37 37 + 38 38 + module type Task = sig 39 39 + type k 40 40 + type v 41 41 + 42 42 + val exec : k -> v 43 43 + 44 44 + module Make (S : Selective) : sig 45 45 + val run : (k -> v S.t) -> v S.t 46 46 + end 47 47 + end 48 48 + 49 49 + module Example : Task with type k = string and type v = int = struct 50 50 + type k = string 51 51 + type v = int 52 52 + 53 53 + let exec s = Sys.command s 54 54 + 55 55 + module Make (Select : Selective) = struct 56 56 + module S = Make (Select) 57 57 + 58 58 + let run exec = 59 59 + S.if' 60 60 + (S.map (exec "node") ~f:(fun x -> x = 0)) 61 61 + (exec "echo 'node!'") (exec "echo 'no node'") 62 62 + end 63 63 + end 64 64 + 65 65 + module Dependencies (Task : Task) : sig 66 66 + val deps : Task.k list 67 67 + val v : Task.v 68 68 + end = struct 69 69 + module Ks = Make (struct 70 70 + type 'a t = Task.k List.t 71 71 + 72 72 + let return _ = [] 73 73 + let apply x y = List.append x y 74 74 + let map = `Define_using_apply 75 75 + let select x y = List.append x y 76 76 + end) 77 77 + 78 78 + module Xs : Selective with type 'a t = 'a = struct 79 79 + type 'a t = 'a 80 80 + 81 81 + let return v = v 82 82 + let apply f y = f y 83 83 + let map = `Define_using_apply 84 84 + 85 85 + let select either f = 86 86 + match either with 87 87 + | Either.Left v -> 88 88 + Format.printf "Either left\n%!"; 89 89 + f v 90 90 + | Either.Right b -> 91 91 + Format.printf "Either right\n%!"; 92 92 + b 93 93 + end 94 94 + 95 95 + module Ys = Make (Xs) 96 96 + module M = Task.Make (Ks) 97 97 + module T = Task.Make (Ys) 98 98 + 99 99 + let deps = M.run (fun v -> [ v ]) 100 100 + let v = T.run Task.exec 101 101 + end 102 102 + 103 103 + let () = 104 104 + let module D = Dependencies (Example) in 105 105 + (* List.iter (Format.printf "Dep: %s\n%!") D.deps; *) 106 106 + Format.printf "Result: %i\n" D.v