Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- module type FunctorType =
- sig
- type 'a t
- val map : ('a -> 'b) -> 'a t -> 'b t
- (** Laws:
- map id x = x
- map (f . g) = map f . map g *)
- end
- module type PointedType =
- sig
- include FunctorType
- val pure : 'a -> 'a t
- (** Law:
- map f . pure = pure . f *)
- end
- module type ApplicativeType =
- sig
- include PointedType
- val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
- (** Law:
- map f x = pure f <*> x *)
- end
- module type MonadType =
- sig
- include ApplicativeType
- val join : 'a t t -> 'a t
- val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
- val (>>) : 'a t -> 'b t -> 'b t
- (** Laws:
- pure a >>= f = f a
- x >>= pure = x
- map f x = x >>= pure . f *)
- end
- module OptionMonad =
- struct
- type 'a t = 'a option
- let map f x =
- match x with
- | Some x' -> Some (f x')
- | None -> None
- let pure x = Some x
- let (<*>) f x =
- match (f, x) with
- | (Some f', Some x') -> Some (f' x')
- | _ -> None
- let join x =
- match x with
- | Some x' -> x'
- | None -> None
- let (>>=) x f = join (pure f <*> x)
- let (>>) x y = x >>= fun _ -> y
- end
- module MakeDummy (Functor : FunctorType) =
- struct
- let id x = x
- let ($.) f g x = f (g x)
- let test_id x =
- (x = Functor.map id x)
- let test_compose f g x =
- let left = Functor.map (f $. g) x in
- let right = (Functor.map f $. Functor.map g) x in
- (left = right)
- end
- module MakeSumInMonad (Monad : MonadType) =
- struct
- let (>>=) = Monad.(>>=)
- let return = Monad.pure
- let maybe_div a b =
- match (a, b) with
- | (Some a', Some b') ->
- if b' = 0 then
- None
- else
- Some (a' / b')
- | _ -> None
- let (+) a b =
- a >>= fun a' ->
- b >>= fun b' ->
- return (Pervasives.(+) a' b')
- end
- module Dummy = MakeDummy (OptionMonad)
- module SumInMaybe = MakeSumInMonad (OptionMonad)
- let main () =
- let id x = x in
- let app x y = y ^ x in
- let bar = app "bar" in
- let (/?) = SumInMaybe.maybe_div in
- let (+?) = SumInMaybe.(+) in
- begin
- assert (Dummy.test_id (Some "foo"));
- assert (Dummy.test_id None);
- assert (Dummy.test_compose bar bar (Some "foo"));
- assert (Dummy.test_compose bar bar None);
- assert (Dummy.test_compose id id (Some "foo"));
- assert ((Some 4) /? (Some 2) +? (Some 3) /? (Some 1) = (Some 5));
- assert ((Some 4) /? (Some 0) +? (Some 3) /? (Some 1) = None);
- end
- ;;
- main ()
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement