commit cbf04400531a7a91c4f91b8f6b5c2cc7fc74d78c · patrick.sirref.org/shelter

attic/dune

···

       1
       +
       ; (executables

     

       2
       +
       ;  (names main task)

     

       3
       +
       ;  (libraries base eio_posix shelter.main))

+129

attic/main.ml

···

       1
       +
       module 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

     

       8
       +
       end

     

       9
       +
       

     

       10
       +
       module type Selective = sig

     

       11
       +
         include Applicative

     

       12
       +
       

     

       13
       +
         val select : ('a, 'b) Either.t t -> ('a -> 'b) t -> 'b t

     

       14
       +
       end

     

       15
       +
       

     

       16
       +
       

     

       17
       +
       module 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

     

       23
       +
       end

     

       24
       +
       

     

       25
       +
       module 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)

     

       44
       +
       end

     

       45
       +
       

     

       46
       +
       module 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

     

       103
       +
       end

     

       104
       +
       

     

       105
       +
       module 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

     

       111
       +
       end)

     

       112
       +
       

     

       113
       +
       module D = Shl (Identity)

     

       114
       +
       

     

       115
       +
       let 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
       +
       

     

       129
       +
       let () = print_endline (D.build dockerfile)

+106

attic/task.ml

···

       1
       +
       (* Work in progress, prototyped in https://try.ocamlpro.com/. To be modified

     

       2
       +
          for Base. *)

     

       3
       +
       

     

       4
       +
       module type Applicative = sig

     

       5
       +
         type 'a t

     

       6
       +
       

     

       7
       +
         val return : 'a -> 'a t

     

       8
       +
         val apply : ('a -> 'b) t -> 'a t -> 'b t

     

       9
       +
       end

     

       10
       +
       

     

       11
       +
       module type Selective = sig

     

       12
       +
         include Applicative

     

       13
       +
       

     

       14
       +
         val select : ('a, 'b) Either.t t -> ('a -> 'b) t -> 'b t

     

       15
       +
       end

     

       16
       +
       

     

       17
       +
       module Make (S : Selective) = struct

     

       18
       +
         include S

     

       19
       +
       

     

       20
       +
         let ( <*? ) x f = S.select x f

     

       21
       +
         let map ~f x = apply (return f) x

     

       22
       +
       

     

       23
       +
         let branch x l r =

     

       24
       +
           map x ~f:(Either.map ~left:Fun.id ~right:Either.left)

     

       25
       +
           <*? map l ~f:(Fun.compose Either.right)

     

       26
       +
           <*? r

     

       27
       +
       

     

       28
       +
         let if' x t f =

     

       29
       +
           branch

     

       30
       +
             (map x ~f:(fun b -> if b then Either.Left () else Either.Right ()))

     

       31
       +
             (map t ~f:Fun.const) (map f ~f:Fun.const)

     

       32
       +
       

     

       33
       +
         let when' x act = if' x act (return ())

     

       34
       +
         let ( <||> ) a b = if' a (return true) b

     

       35
       +
         let ( <&&> ) a b = if' a b (return false)

     

       36
       +
       end

     

       37
       +
       

     

       38
       +
       module type Task = sig

     

       39
       +
         type k

     

       40
       +
         type v

     

       41
       +
       

     

       42
       +
         val exec : k -> v

     

       43
       +
       

     

       44
       +
         module Make (S : Selective) : sig

     

       45
       +
           val run : (k -> v S.t) -> v S.t

     

       46
       +
         end

     

       47
       +
       end

     

       48
       +
       

     

       49
       +
       module Example : Task with type k = string and type v = int = struct

     

       50
       +
         type k = string

     

       51
       +
         type v = int

     

       52
       +
       

     

       53
       +
         let exec s = Sys.command s

     

       54
       +
       

     

       55
       +
         module Make (Select : Selective) = struct

     

       56
       +
           module S = Make (Select)

     

       57
       +
       

     

       58
       +
           let run exec =

     

       59
       +
             S.if'

     

       60
       +
               (S.map (exec "node") ~f:(fun x -> x = 0))

     

       61
       +
               (exec "echo 'node!'") (exec "echo 'no node'")

     

       62
       +
         end

     

       63
       +
       end

     

       64
       +
       

     

       65
       +
       module Dependencies (Task : Task) : sig

     

       66
       +
         val deps : Task.k list

     

       67
       +
         val v : Task.v

     

       68
       +
       end = struct

     

       69
       +
         module Ks = Make (struct

     

       70
       +
           type 'a t = Task.k List.t

     

       71
       +
       

     

       72
       +
           let return _ = []

     

       73
       +
           let apply x y = List.append x y

     

       74
       +
           let map = `Define_using_apply

     

       75
       +
           let select x y = List.append x y

     

       76
       +
         end)

     

       77
       +
       

     

       78
       +
         module Xs : Selective with type 'a t = 'a = struct

     

       79
       +
           type 'a t = 'a

     

       80
       +
       

     

       81
       +
           let return v = v

     

       82
       +
           let apply f y = f y

     

       83
       +
           let map = `Define_using_apply

     

       84
       +
       

     

       85
       +
           let select either f =

     

       86
       +
             match either with

     

       87
       +
             | Either.Left v ->

     

       88
       +
                 Format.printf "Either left\n%!";

     

       89
       +
                 f v

     

       90
       +
             | Either.Right b ->

     

       91
       +
                 Format.printf "Either right\n%!";

     

       92
       +
                 b

     

       93
       +
         end

     

       94
       +
       

     

       95
       +
         module Ys = Make (Xs)

     

       96
       +
         module M = Task.Make (Ks)

     

       97
       +
         module T = Task.Make (Ys)

     

       98
       +
       

     

       99
       +
         let deps = M.run (fun v -> [ v ])

     

       100
       +
         let v = T.run Task.exec

     

       101
       +
       end

     

       102
       +
       

     

       103
       +
       let () =

     

       104
       +
         let module D = Dependencies (Example) in

     

       105
       +
         (* List.iter (Format.printf "Dep: %s\n%!") D.deps; *)

     

       106
       +
         Format.printf "Result: %i\n" D.v