star.ml

module Functor = struct
  module type S = sig
    type 'a t

    val map : ('a -> 'b) -> 'a t -> 'b t
  end

  module type API = sig
    include S

    val ( <$> ) : ('a -> 'b) -> 'a t -> 'b t
    val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
    val void : 'a t -> unit t
  end

  module Make (S : S) : API with type 'a t = 'a S.t = struct
    include S

    let ( <$> ) f at = map f at
    let ( let+ ) at ft = map ft at
    let void t = map (fun _ -> ()) t
  end
end

module Applicative = struct
  module type S = sig
    include Functor.S

    val pure : 'a -> 'a t
    val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t
  end

  module type API = sig
    include S
    include Functor.API with type 'a t := 'a t

    val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
    val when_ : bool -> unit t -> unit t
    val unless : bool -> unit t -> unit t
  end

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

    let pair a b = (a, b)
    let ( and+ ) at bt = pair <$> at <*> bt
    let when_ b t = if b then t else pure ()
    let unless b t = if b then pure () else t
  end
end

module Alternative = struct
  module type S = sig
    include Applicative.S

    val ( <|> ) : 'a t -> 'a t -> 'a t
    val empty : 'a t
  end

  module type API = sig
    include S
    include Applicative.API with type 'a t := 'a t

    val guard : bool -> unit t
    val optional : 'a t -> 'a option t
  end

  module Make (S : S) : API with type 'a t = 'a S.t = struct
    include S
    module A = Applicative.Make (S)
    include A

    let guard = function true -> pure () | false -> empty
    let optional t = map Option.some t <|> pure None
  end
end

module Monad = struct
  module type S = sig
    include Applicative.S

    val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
  end

  module type API = sig
    include S
    include Applicative.API with type 'a t := 'a t

    val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
  end

  module Make (S : S) : API with type 'a t = 'a S.t = struct
    include S
    module A = Applicative.Make (S)
    include A

    let ( let* ) = ( >>= )
  end
end

module MonadPlus = struct
  module type S = sig
    include Monad.S
    include Alternative.S with type 'a t := 'a t

    val zero : 'a t
    val plus : 'a t -> 'a t -> 'a t
  end

  module type API = sig
    include S
    include Monad.API with type 'a t := 'a t
    include Alternative.API with type 'a t := 'a t
  end

  module Make (S : S) : API with type 'a t = 'a S.t = struct
    include S
    module A = Monad.Make (S)
    include A
    module B = Alternative.Make (S)
    include B
  end
end

module Category = struct
  module type S = sig
    type ('a, 'b) t

    val id : ('a, 'a) t
    val ( @ ) : ('b, 'c) t -> ('a, 'b) t -> ('a, 'c) t
  end

  module type API = sig
    include S
  end

  module Make (S : S) : API with type ('a, 'b) t = ('a, 'b) S.t = struct
    include S
  end
end

module type T = sig
  type t
end

module Star (F : sig
  type 'a t
end) : sig
  type ('d, 'c) t = 'd -> 'c F.t

  module Category (_ : Monad.S with type 'a t = 'a F.t) :
    Category.API with type ('a, 'b) t = ('a, 'b) t

  module Functor (_ : Functor.S with type 'a t = 'a F.t) (A : T) :
    Functor.API with type 'a t = (A.t, 'a) t

  module Applicative (_ : Applicative.S with type 'a t = 'a F.t) (A : T) :
    Applicative.API with type 'a t = (A.t, 'a) t

  module Alternative (_ : Alternative.S with type 'a t = 'a F.t) (A : T) :
    Alternative.API with type 'a t = (A.t, 'a) t

  module Monad (_ : Monad.S with type 'a t = 'a F.t) (A : T) :
    Monad.API with type 'a t = (A.t, 'a) t

  module MonadPlus (_ : MonadPlus.S with type 'a t = 'a F.t) (A : T) :
    MonadPlus.API with type 'a t = (A.t, 'a) t
end = struct
  type ('d, 'c) t = 'd -> 'c F.t

  module Category (F : Monad.S with type 'a t = 'a F.t) :
    Category.API with type ('a, 'b) t = ('a, 'b) t = struct
    module F = Category.Make (struct
      type nonrec ('a, 'b) t = ('a, 'b) t

      open F

      let id v = pure v
      let ( @ ) g f v = f v >>= g
    end)

    include F
  end

  module Functor (F : Functor.S with type 'a t = 'a F.t) (A : T) :
    Functor.API with type 'a t = (A.t, 'a) t = struct
    module F = Functor.Make (struct
      type nonrec 'a t = (A.t, 'a) t

      open F

      let map f t v = map f (t v)
    end)

    include F
  end

  module Applicative (F : Applicative.S with type 'a t = 'a F.t) (A : T) :
    Applicative.API with type 'a t = (A.t, 'a) t = struct
    module F = Applicative.Make (struct
      module P = Functor (F) (A)
      include P
      open F

      let pure a _ = pure a
      let ( <*> ) ft at v = ft v <*> at v
    end)

    include F
  end

  module Alternative (F : Alternative.S with type 'a t = 'a F.t) (A : T) :
    Alternative.API with type 'a t = (A.t, 'a) t = struct
    module F = Alternative.Make (struct
      module P = Applicative (F) (A)
      include P
      open F

      let empty _ = empty
      let ( <|> ) f g a = f a <|> g a
    end)

    include F
  end

  module Monad (F : Monad.S with type 'a t = 'a F.t) (A : T) :
    Monad.API with type 'a t = (A.t, 'a) t = struct
    module F = Monad.Make (struct
      module P = Applicative (F) (A)
      include P
      open F

      let ( >>= ) m f v = m v >>= fun a -> (f a) v
    end)

    include F
  end

  module MonadPlus (F : MonadPlus.S with type 'a t = 'a F.t) (A : T) :
    MonadPlus.API with type 'a t = (A.t, 'a) t = struct
    module F = MonadPlus.Make (struct
      module P1 = Alternative (F) (A)
      include P1
      module P2 = Monad (F) (A)
      include P2
      open F

      let zero _ = zero
      let plus f g v = plus (f v) (g v)
    end)

    include F
  end
end

module First : sig
  type 'a t = 'a option

  include MonadPlus.S with type 'a t := 'a t
end = struct
  type 'a t = 'a option

  let map f = function None -> None | Some v -> Some (f v)
  let pure a = Some a

  let ( <*> ) ft at =
    match (ft, at) with Some f, Some v -> Some (f v) | _, _ -> None

  let empty = None
  let ( <|> ) t1 t2 = match t1 with None -> t2 | Some _ as t1 -> t1
  let ( >>= ) m k = match m with None -> None | Some v -> k v
  let zero = empty
  let plus = ( <|> )
end

module Object : sig
  type t

  val int : int -> t
  val is_int : t -> bool
  val get_int : t -> int
  val string : string -> t
  val is_string : t -> bool
  val get_string : t -> string
end = struct
  type t = Int of int | String of string

  let int i = Int i
  let is_int = function Int _ -> true | _ -> false
  let get_int = function Int i -> i | _ -> failwith "Not an int"
  let string s = String s
  let is_string = function String _ -> true | _ -> false
  let get_string = function String s -> s | _ -> failwith "Not a string"
end

module Parser : sig
  type 'a t

  val runParser : 'a t -> Object.t -> 'a Option.t
  val id : Object.t t [@@ocaml.warning "-32"]
  val int : int t
  val string : string t

  include MonadPlus.API with type 'a t := 'a t
end = struct
  module Star' = Star (First)
  module Cat = Star'.Category (First)
  include Cat
  module MonadPlus' = Star'.MonadPlus (First) (Object)
  include MonadPlus'

  let runParser t o = t o

  let int =
    let* v = id in
    let+ () = guard (Object.is_int v) in
    Object.get_int v

  let string =
    let* v = id in
    let+ () = guard (Object.is_string v) in
    Object.get_string v
end

let () =
  let open Parser in
  let () =
    match runParser string (Object.int 1) with
    | None -> ()
    | Some _ -> assert false
  in
  let () =
    match runParser int (Object.string "") with
    | None -> ()
    | Some _ -> assert false
  in
  let () =
    match runParser (pure false) (Object.int 1) with
    | Some false -> ()
    | _ -> assert false
  in
  let () =
    match
      runParser (map Either.left int <|> map Either.right string) (Object.int 1)
    with
    | Some (Left 1) -> ()
    | _ -> assert false
  in
  let () =
    match
      runParser
        (map Either.left int <|> map Either.right string)
        (Object.string "abc")
    with
    | Some (Right "abc") -> ()
    | _ -> assert false
  in
  let () =
    match
      runParser
        (let* _ = int in
         string)
        (Object.int 1)
    with
    | None -> ()
    | _ -> assert false
  in
  let () =
    match
      runParser
        (let* i = int in
         map Either.left string <|> map Either.right (pure (i + 1)))
        (Object.int 10)
    with
    | Some (Right 11) -> ()
    | _ -> assert false
  in
  let () =
    match
      runParser
        (let* s = string in
         map Either.left int <|> map Either.right (pure (String.length s)))
        (Object.int 10)
    with
    | None -> ()
    | _ -> assert false
  in
  let () =
    match
      runParser
        (let* s = string in
         map Either.left int <|> map Either.right (pure (String.length s)))
        (Object.string "abc")
    with
    | Some (Right 3) -> ()
    | _ -> assert false
  in
  ()