Last active
February 7, 2024 00:09
-
-
Save NicolasT/8af491dd7e2556399c3eb31ea7b9c5ae to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 | |
() |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment