Instantly share code, notes, and snippets.

@0branch /applicative.ml Secret
Created Mar 26, 2012

Embed
What would you like to do?
Applicative example (full)
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))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment