Bedrock

applicative.ml

open Util

module Make (A : Sigs.Applicative.REQUIREMENT) :
  Sigs.Applicative.API with type 'a t = 'a A.t = struct
  module F = Functor.Make (struct
    type 'a t = 'a A.t

    let pure = A.pure
    let map f x = A.ap (pure f) x
  end)

  module Api = struct
    include A

    let map = F.map
    let lift = F.lift
    let lift2 f a = ap (lift f a)
    let lift3 f a b c = ap (lift2 f a b) c
    let lift4 f a b c d = ap (lift3 f a b c) d
  end

  include Api

  module Infix = struct
    include F.Infix

    let ( <*> ) = ap
    let ( <**> ) x f = f <*> x
    let ( <* ) a b = lift2 const a b
    let ( *> ) a b = id <$ a <*> b
  end

  include Infix
end

module From_monad (M : Sigs.Monad.REQUIREMENT_BIND) :
  Sigs.Applicative.REQUIREMENT with type 'a t = 'a M.t = struct
  type 'a t = 'a M.t

  let pure = M.return
  let ap fs xs = M.bind (fun f -> M.bind (fun x -> pure (f x)) xs) fs
end

module Make_from_monad (M : Sigs.Monad.REQUIREMENT_BIND) :
  Sigs.Applicative.API with type 'a t = 'a M.t = struct
  include Make (From_monad (M))
end

example_validation.ml

let check_day = function
  | None ->
    Glue.Util.day () |> Validation.from_result
  | Some x ->
    Timetable.Day.from_string x |> Validation.from_result
;;

let check_duration =
  Validation.from_option (Invalid_field "duration")
;;

let check_sector sectors = function
  | None ->
    Error [Invalid_field "sector"]
  | Some x ->
    let open Validation.Infix in
    Validation.from_option
      (Unknown ("sector: " ^ x))
      (Hashtbl.find_opt sectors x)
    >|= fun x -> x.Shapes.Sector.name
;;

let check_project projects = function
  | None ->
    Ok None
  | Some x ->
    let open Validation.Infix in
    let flag =
      List.find_opt (fun p -> p.Shapes.Project.name = x) projects
    in
    Validation.from_option (Unknown ("project: " ^ x)) flag
    >|= fun x -> Some x.Shapes.Project.name
;;

let check_label x =
  if String.length (String.trim x) = 0
  then Error [Invalid_field "label"]
  else Ok x
;;

let record sector duration timecode project label =
  ensure_sectors_projects (fun sectors projects ->
      let open Validation.Infix in
      let potential_log =
        Shapes.Log.new_log (Uuid.make () |> Uuid.to_string)
        <$> check_day timecode <*> check_duration duration
        <*> check_sector sectors sector
        <*> check_project projects project
        <*> check_label (String.concat " " label)
      in
      match potential_log with
      | Error xs ->
        Prompter.prompt_errors xs
      | Ok log ->
        visual_push log )
;;

functor.ml

open Util

module Make (F : Sigs.Functor.REQUIREMENT) :
  Sigs.Functor.API with type 'a t = 'a F.t = struct
  module Api = struct
    include F

    let lift = map
  end

  include Api

  module Infix = struct
    let ( <$> ) = map
    let ( <&> ) x f = map f x
    let ( <$ ) x tx = (map % const) x tx
    let ( $> ) tx x = x <$ tx
  end

  include Infix
end

list.ml

type 'a t = 'a list

module L = Stdlib.List

let zip left right =
  try Some (L.map2 (fun x y -> x, y) left right) with _ -> None
;;

let eq f left right =
  match zip left right with
  | None ->
    false
  | Some l ->
    L.for_all (fun (x, y) -> f x y) l
;;

module Functor = Functor.Make (struct
  type 'a t = 'a list

  let pure x = [x]
  let map f x = Stdlib.List.map f x
end)

module Monad = struct
  include Monad.Make_with_join (struct
    type 'a t = 'a list

    let return x = [x]
    let map = Stdlib.List.map
    let join = Stdlib.List.concat
  end)

  module Traversable (M : Sigs.Monad.API) = struct
    type 'a t = 'a M.t

    let traverse =
      let open M.Infix in
      let rec aux f = function
        | [] ->
          M.return []
        | x :: xs ->
          f x
          >>= fun h ->
          aux f xs >>= fun t -> M.return (Stdlib.List.cons h t)
      in
      aux
    ;;

    let sequence x = traverse Util.id x
  end
end

module Applicative = struct
  include Applicative.Make_from_monad (Monad)

  module Traversable (A : Sigs.Applicative.API) = struct
    type 'a t = 'a A.t

    let traverse =
      let open A.Infix in
      let rec aux f = function
        | [] ->
          A.pure []
        | x :: xs ->
          Stdlib.List.cons <$> f x <*> aux f xs
      in
      aux
    ;;

    let sequence x = traverse Util.id x
  end
end

include L

module Infix = struct
  include Functor.Infix
  include Monad.Infix
  include Applicative.Infix
end

include Functor.Api
include Monad.Api
include Applicative.Api
include Infix

monad.ml

open Util

module type REQ = sig
  include Sigs.Monad.REQUIREMENT_BIND
  include Sigs.Monad.REQUIREMENT_JOIN with type 'a t := 'a t
end

module Join (M : Sigs.Monad.REQUIREMENT_JOIN) :
  REQ with type 'a t = 'a M.t = struct
  include M

  let bind f m = join (map f m)
end

module Bind (M : Sigs.Monad.REQUIREMENT_BIND) :
  REQ with type 'a t = 'a M.t = struct
  include M

  let join m = bind id m
  let map f m = bind (return % f) m
end

module WithReq (M : REQ) : Sigs.Monad.API with type 'a t = 'a M.t =
struct
  module Api = struct
    include M

    let ( >>= ) x f = bind f x
    let lift = map
    let lift2 f a b = a >>= fun x -> b >>= fun y -> return (f x y)

    let lift3 f a b c =
      a >>= fun x -> b >>= fun y -> c >>= fun z -> return (f x y z)
    ;;

    let lift4 f a b c d =
      a
      >>= fun w ->
      b >>= fun x -> c >>= fun y -> d >>= fun z -> return (f w x y z)
    ;;

    let void _ = return ()
  end

  include Api

  module Infix = struct
    let ( >>= ) x f = M.bind f x
    let ( >|= ) x f = M.map f x
    let ( >> ) m n = m >>= fun _ -> n
    let ( <=< ) f g x = g x >>= f
    let ( >=> ) f g = flip ( <=< ) f g
    let ( =<< ) = M.bind
  end

  include Infix
end

module Make_with_join (M : Sigs.Monad.REQUIREMENT_JOIN) :
  Sigs.Monad.API with type 'a t = 'a M.t = struct
  include WithReq (Join (M))
end

module Make_with_bind (M : Sigs.Monad.REQUIREMENT_BIND) :
  Sigs.Monad.API with type 'a t = 'a M.t = struct
  include WithReq (Bind (M))
end

option.ml

type 'a t = 'a option

let eq f left right =
  match left, right with
  | None, None ->
    true
  | Some x, Some y ->
    f x y
  | _ ->
    false
;;

let is_valid = function Some _ -> true | None -> false

module Functor = Functor.Make (struct
  type 'a t = 'a option

  let pure x = Some x
  let map f = function None -> None | Some x -> Some (f x)
end)

module Monad = struct
  module M = Monad.Make_with_bind (struct
    type 'a t = 'a option

    let return x = Some x
    let bind f = function None -> None | Some x -> f x
  end)

  include M

  include (
    List.Monad.Traversable
      (M) :
      Sigs.TRAVERSABLE with type 'a t := 'a t )
end

module Applicative = struct
  module A = Applicative.Make_from_monad (Monad)
  include A

  include (
    List.Applicative.Traversable
      (A) :
      Sigs.TRAVERSABLE with type 'a t := 'a t )
end

module Infix = struct
  include Functor.Infix
  include Monad.Infix
  include Applicative.Infix
end

include Functor.Api
include Monad.Api
include Applicative.Api
include Infix

sigs.mli

(** The module exposes API and requirement. *)

module Base_Infix : sig
  (** The parametrized type. *)
  type 'a t

  (** Replace all locations in the input with the same value. *)
  val ( <$ ) : 'a -> 'b t -> 'a t

  (** Flipped version of [ <$ ]. *)
  val ( $> ) : 'a t -> 'b -> 'b t

  (** Infix version of [map]. *)
  val ( <$> ) : ('a -> 'b) -> 'a t -> 'b t

  (** Flipped version of [<$>]. *)
  val ( <&> ) : 'a t -> ('a -> 'b) -> 'b t
end

module Base_Lift : sig
  (** The parametrized type. *)
  type 'a t

  (** Lift a unary function to actions. *)
  val lift : ('a -> 'b) -> 'a t -> 'b t

  (** Lift a binary function to actions. *)
  val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t

  (** Lift a ternary function to actions. *)
  val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t

  (** Lift a quadratic function to actions. *)
  val lift4 :
       ('a -> 'b -> 'c -> 'd -> 'e)
    -> 'a t
    -> 'b t
    -> 'c t
    -> 'd t
    -> 'e t
end

module Functor : sig
  (** Describe the requirement to produce a [Functor] (as a Module) *)
  module type REQUIREMENT = sig
    (** The parametrized type. *)
    type 'a t

    (** Wrap value into a Functor. *)
    val pure : 'a -> 'a t

    (** Mapping over ['a t]. *)
    val map : ('a -> 'b) -> 'a t -> 'b t
  end

  (** Describes a complete interface for functor. *)
  module type API = sig
    type 'a t

    module Api : sig
      include REQUIREMENT with type 'a t := 'a t

      (** Alias of [map]. *)
      val lift : ('a -> 'b) -> 'a t -> 'b t
    end

    include module type of Api
    module Infix : module type of Base_Infix with type 'a t := 'a t
    include module type of Infix
  end
end

module Applicative : sig
  (** Describe the requirement to produce an [Applicative Functor] 
      (as a Module) 
  *)
  module type REQUIREMENT = sig
    (** The parametrized type. *)
    type 'a t

    (** Wrap value into an Applicative. *)
    val pure : 'a -> 'a t

    (** Sequential application *)
    val ap : ('a -> 'b) t -> 'a t -> 'b t
  end

  (** Describes a complete interface for applicative functor. *)
  module type API = sig
    type 'a t

    module Api : sig
      include REQUIREMENT with type 'a t := 'a t

      (** Mapping over ['a t]. *)
      val map : ('a -> 'b) -> 'a t -> 'b t

      include module type of Base_Lift with type 'a t := 'a t
    end

    include module type of Api

    module Infix : sig
      include module type of Base_Infix with type 'a t := 'a t

      (** Infix version of [ap].*)
      val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t

      (** Sequence actions, discarding the value of the first argument. *)
      val ( *> ) : 'a t -> 'b t -> 'b t

      (** Sequence actions, discarding the value of the second argument. *)
      val ( <* ) : 'a t -> 'b t -> 'a t

      (** Flipped version of [<*>]. *)
      val ( <**> ) : 'a t -> ('a -> 'b) t -> 'b t
    end

    include module type of Infix
  end
end

module Monad : sig
  module type REQUIREMENT_BIND = sig
    (** The parametrized type. *)
    type 'a t

    (** Wrap value into an Applicative. *)
    val return : 'a -> 'a t

    (** Sequentially compose two actions, passing any value produced by the
        first as an argument to the second.
    *)
    val bind : ('a -> 'b t) -> 'a t -> 'b t
  end

  module type REQUIREMENT_JOIN = sig
    (** The parametrized type. *)
    type 'a t

    (** Wrap value into an Applicative. *)
    val return : 'a -> 'a t

    (** Mapping over ['a t]. *)
    val map : ('a -> 'b) -> 'a t -> 'b t

    (** The join function is the conventional monad join operator.
        It is used to remove one level of monadic structure, projecting its
        bound argument into the outer level.
    *)
    val join : 'a t t -> 'a t
  end

  module type API = sig
    type 'a t

    module Api : sig
      include REQUIREMENT_JOIN with type 'a t := 'a t
      include REQUIREMENT_BIND with type 'a t := 'a t
      include module type of Base_Lift with type 'a t := 'a t

      (** void value discards or ignores the result of evaluation, such as the
        return value of an IO action. 
    *)
      val void : 'a t -> unit t
    end

    include module type of Api

    module Infix : sig
      (** Flipped infix version of [bind]. *)
      val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t

      (** Flipped infix version of [map]. *)
      val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t

      (** Right-to-left Kleisli composition of monads. [(>=>)], 
          with the arguments flipped 
      *)
      val ( <=< ) : ('b -> 'c t) -> ('a -> 'b t) -> 'a -> 'c t

      (** Left-to-right Kleisli composition of monads. *)
      val ( >=> ) : ('a -> 'b t) -> ('b -> 'c t) -> 'a -> 'c t

      (** Flipped version of [>>=] *)
      val ( =<< ) : ('a -> 'b t) -> 'a t -> 'b t

      (** Sequentially compose two actions, discarding any value produced 
          by the first, like sequencing operators (such as the semicolon) 
          in imperative languages. 
      *)
      val ( >> ) : 'a t -> 'b t -> 'b t
    end

    include module type of Infix
  end
end

module type TRAVERSABLE = sig
  (** The parametrized type. *)
  type 'a t

  val traverse : ('a -> 'b t) -> 'a list -> 'b list t
  val sequence : 'a t list -> 'a list t
end

validation.ml

type 'a t = ('a, Error.t list) result
type 'a st = 'a t

let pop f = function Ok x -> x | Error err -> f err
let is_valid = function Ok _ -> true | Error _ -> false
let from_result = function Ok x -> Ok x | Error x -> Error [x]

let from_option error = function
  | Some x ->
    Ok x
  | None ->
    Error [error]
;;

module Functor = Functor.Make (struct
  type 'a t = 'a st

  let pure x = Ok x
  let map f = function Error x -> Error x | Ok x -> Ok (f x)
end)

module Monad = struct
  module M = Monad.Make_with_bind (struct
    type 'a t = 'a st

    let return x = Ok x
    let bind f = function Error x -> Error x | Ok x -> f x
  end)

  include M

  include (
    List.Monad.Traversable
      (M) :
      Sigs.TRAVERSABLE with type 'a t := 'a t )
end

module Applicative = struct
  module A = Applicative.Make (struct
    type 'a t = 'a st

    let pure x = Ok x

    let ap af ax =
      match af, ax with
      | Ok f, Ok x ->
        Ok (f x)
      | Error a, Error b ->
        Error (a @ b)
      | Error a, _ | _, Error a ->
        Error a
    ;;
  end)

  include A

  include (
    List.Applicative.Traversable
      (A) :
      Sigs.TRAVERSABLE with type 'a t := 'a t )
end

module Infix = struct
  include Functor.Infix
  include Monad.Infix
  include Applicative.Infix
end

(** Instance inclusion *)

include Functor.Api
include Monad.Api
include Applicative.Api
include Infix