SHARE
TWEET

vlan

a guest Jul 13th, 2009 140 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. module type FunctorType =
  2. sig
  3.   type 'a t
  4.   val map : ('a -> 'b) -> 'a t -> 'b t
  5.   (** Laws:
  6.  
  7.       map id x = x
  8.       map (f . g) = map f . map g *)
  9. end
  10.  
  11. module type PointedType =
  12. sig
  13.   include FunctorType
  14.   val pure : 'a -> 'a t
  15.   (** Law:
  16.      
  17.       map f . pure = pure . f *)
  18. end
  19.  
  20. module type ApplicativeType =
  21. sig
  22.   include PointedType
  23.   val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
  24.   (** Law:
  25.      
  26.       map f x = pure f <*> x *)
  27. end
  28.  
  29. module type MonadType =
  30. sig
  31.   include ApplicativeType
  32.   val join : 'a t t -> 'a t
  33.   val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
  34.   val (>>) : 'a t -> 'b t -> 'b t
  35.   (** Laws:
  36.  
  37.       pure a >>= f = f a
  38.       x >>= pure = x
  39.       map f x = x >>= pure . f *)
  40. end
  41.  
  42. module OptionMonad =
  43. struct
  44.   type 'a t = 'a option
  45.  
  46.   let map f x =
  47.     match x with
  48.       | Some x' -> Some (f x')
  49.       | None -> None
  50.  
  51.   let pure x = Some x
  52.  
  53.   let (<*>) f x =
  54.     match (f, x) with
  55.       | (Some f', Some x') -> Some (f' x')
  56.       | _ -> None
  57.      
  58.   let join x =
  59.     match x with
  60.       | Some x' -> x'
  61.       | None -> None
  62.  
  63.   let (>>=) x f = join (pure f <*> x)
  64.   let (>>) x y = x >>= fun _ -> y
  65. end
  66.  
  67. module MakeDummy (Functor : FunctorType) =
  68. struct
  69.   let id x = x
  70.   let ($.) f g x = f (g x)
  71.  
  72.   let test_id x =
  73.     (x = Functor.map id x)
  74.  
  75.   let test_compose f g x =
  76.     let left = Functor.map (f $. g) x in
  77.     let right = (Functor.map f $. Functor.map g) x in
  78.     (left = right)
  79. end
  80.  
  81. module MakeSumInMonad (Monad : MonadType) =
  82. struct
  83.   let (>>=) = Monad.(>>=)
  84.   let return = Monad.pure
  85.  
  86.   let maybe_div a b =
  87.     match (a, b) with
  88.       | (Some a', Some b') ->
  89.         if b' = 0 then
  90.           None
  91.         else
  92.           Some (a' / b')
  93.       | _ -> None
  94.  
  95.   let (+) a b =
  96.     a >>= fun a' ->
  97.     b >>= fun b' ->
  98.     return (Pervasives.(+) a' b')
  99. end
  100.  
  101. module Dummy = MakeDummy (OptionMonad)
  102. module SumInMaybe = MakeSumInMonad (OptionMonad)
  103.  
  104. let main () =
  105.   let id x = x in
  106.   let app x y = y ^ x in
  107.   let bar = app "bar" in
  108.   let (/?) = SumInMaybe.maybe_div in
  109.   let (+?) = SumInMaybe.(+) in
  110.   begin
  111.     assert (Dummy.test_id (Some "foo"));
  112.     assert (Dummy.test_id None);
  113.     assert (Dummy.test_compose bar bar (Some "foo"));
  114.     assert (Dummy.test_compose bar bar None);
  115.     assert (Dummy.test_compose id id (Some "foo"));
  116.     assert ((Some 4) /? (Some 2) +? (Some 3) /? (Some 1) = (Some 5));
  117.     assert ((Some 4) /? (Some 0) +? (Some 3) /? (Some 1) = None);
  118.   end
  119. ;;
  120.  
  121. main ()
RAW Paste Data
Top