Applicative example (full)

applicative.ml

module type Functor = sig
    type 'a t
    val fmap: ('a -> 'b) -> 'a t -> 'b t
end

module type ApplicativeFunctor = sig
    include Functor

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

module type Lift = sig
    type 'a t
    val lift:  ('a -> 'b) -> 'a t -> 'b t
    val lift2: ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
    val lift3: ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t
end

module ApplicativeLift(A: ApplicativeFunctor) : Lift with type 'a t := 'a A.t = struct
    include A
    let lift  f a       = f <$> a
    let lift2 f a b     = f <$> a <*> b
    let lift3 f a b c   = f <$> a <*> b <*> c
end

(* Composition of ApplicativeFunctor and Lift *)
module type Applicative = sig
    include Lift 
    include ApplicativeFunctor with type 'a t := 'a t
end

(* -- Implementations -------------------------------------------------- *)

(* First of all, let's define a validation type *)
type except          = Exception of string
type 'a validation   = Valid of 'a | Error of except
(* ...and a more general either type *)
type ('a, 'b) either = Left of 'a | Right of 'b

module OptionFunctor : Functor with type 'a t = 'a option = struct
    type 'a t = 'a option
    let fmap f = function
        Some a  -> Some (f a)
        | _     -> None
end

module ValidationFunctor : Functor with type 'a t = 'a validation = struct
    type 'a t = 'a validation
    let fmap f = function
        Valid a     -> Valid (f a)
        | Error err -> Error err
end

module type Typed = sig type t end

module EitherFunctor(T: Typed) : Functor with type 'a t = (T.t, 'a) either = struct
    type 'a t = (T.t, 'a) either
    let fmap f = function
        Right r     -> Right (f r)
        | Left l    -> Left l
end

module OptionApplicativeF : ApplicativeFunctor with type 'a t = 'a option = struct
    include OptionFunctor

    let pure x = Some x

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

    let (<$>) = fmap
end

module ValidationApplicativeF : ApplicativeFunctor with type 'a t = 'a validation = struct
    include ValidationFunctor

    let pure x = Valid x

    let (<*>) f a = match (f, a) with
        (Valid f, Valid a)  -> Valid (f a)
        | (Error err, _)    -> Error err
        | (_, Error err)    -> Error err

    let (<$>) = fmap
end

module EitherApplicativeF(T: Typed) : ApplicativeFunctor with type 'a t = (T.t, 'a) either = struct
    include EitherFunctor(T)

    let pure x = Right x

    let (<*>) f a = match (f, a) with
        (Right f, Right a)  -> Right (f a)
        | (Left err, _)     -> Left err
        | (_, Left err)     -> Left err

    let (<$>) = fmap
end

module OptionApplicative : Applicative with type 'a t = 'a option = struct
    include OptionApplicativeF
    include ApplicativeLift(OptionApplicativeF)
end

module ValidationApplicative : Applicative with type 'a t = 'a validation = struct
    include ValidationApplicativeF
    include ApplicativeLift(ValidationApplicativeF)
end

module EitherApplicative(T: Typed) : Applicative with type 'a t = (T.t, 'a) either = struct
    module EA = EitherApplicativeF(T)
    include EA
    include ApplicativeLift(EA)
end

module Demo(A: Applicative) = struct
    include A
    let double x  = x * 2
    let eg1 x     = lift double x
    let eg2 x y   = lift2 (+) x y
    let eg3 x     = double <$> x
    let eg4 x y   = (+) <$> x <*> y
    let eg5 f x y = lift2 f x y
end

module OptionDemo       = Demo(OptionApplicative)
module ValidationDemo   = Demo(ValidationApplicative)
module EitherStringDemo = Demo(EitherApplicative(String))
module EitherIntDemo    = Demo(EitherApplicative(struct type t = int end))