Source file primavera.ml

(* Copyright (c) 2026, Cargocut and the Primavera developers.
   All rights reserved.

   SPDX-License-Identifier: MIT *)

module Sig = Sig
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 run_computation ~handler program = program handler
    let perform program = program
    let perform_value f env = T.return (f env)
    let local f comp env = comp (f env)
    let handler env = T.return env
    let return x _ = T.return x
    let map f comp x = T.map f (comp x)
    let apply fs comp x = T.apply (fs x) (comp x)
    let bind comp f x = T.bind (comp 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 _ -> mb
      let ( << ) ma mb = ma >>= fun a -> (fun _ -> a) <$> mb
    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

    module Traversable (T : Sig.Req.T1) = struct
      let traverse f c env = T.traverse (fun x -> f x env) c
      let sequence c = traverse (fun x -> x) c
    end

    module List = Traversable (struct
        type 'a foldable = 'a list
        type 'a applicative = 'a T.t

        let traverse f l =
          let rec aux acc = function
            | [] -> T.map Stdlib.List.rev acc
            | x :: xs ->
              aux (T.apply (T.map (fun xs x -> x :: xs) acc) (f x)) xs
          in
          aux (T.return []) l
        ;;
      end)
  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 run_computation ~handler program = program handler
    let perform program = program
    let perform_value f env = T.return (f env)
    let local f comp env = comp (f env)
    let handler env = T.return env
    let return x _ = T.return x
    let map f comp x = T.map f (comp x)
    let apply fs comp x = T.apply (fs x) (comp x)
    let bind comp f x = T.bind (comp 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 _ -> mb
      let ( << ) ma mb = ma >>= fun a -> (fun _ -> a) <$> mb
    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

    module Traversable (T : Sig.Req.T2) = struct
      let traverse f c env = T.traverse (fun x -> f x env) c
      let sequence c = traverse (fun x -> x) c
    end

    module List = Traversable (struct
        type 'a foldable = 'a list
        type ('a, 'e) applicative = ('a, 'e) T.t

        let traverse f l =
          let rec aux acc = function
            | [] -> T.map Stdlib.List.rev acc
            | x :: xs ->
              aux (T.apply (T.map (fun xs x -> x :: xs) acc) (f x)) xs
          in
          aux (T.return []) l
        ;;
      end)
  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)

module Result = Make.S2 (struct
    type ('a, 'b) t = ('a, 'b) result =
      | Ok of 'a
      | Error of 'b

    let return x = Ok x
    let map f x = Result.map f x
    let bind x f = Result.bind x f

    let apply fx xs =
      match fx with
      | Error err -> Error err
      | Ok f ->
        (match xs with
         | Error err -> Error err
         | Ok x -> Ok (f x))
    ;;
  end)

module Option = Make.S1 (struct
    type 'a t = 'a option =
      | None
      | Some of 'a

    let return x = Some x
    let map f x = Option.map f x
    let bind x f = Option.bind x f

    let apply fx xs =
      match fx with
      | None -> None
      | Some f ->
        (match xs with
         | None -> None
         | Some x -> Some (f x))
    ;;
  end)