monads.ml

module type Monad = sig
  
type 'a t   
val return: 'a -> 'a t
val bind:   'a t -> ('a -> 'b t) -> 'b t


end

module ErrorMonad : Monad = struct
  
type 'a t 
  = Ok    of 'a
  | Error of string

let return a = Ok a
let bind m f = match m with
  | Ok a      -> f a
  | Error msg -> Error msg


end

module List = struct
  

type 'a result 
  = Ok    of 'a
  | Error of string

let return x  = Ok x  (* could have also been named "ok" *)
let error msg = Error msg




let hd = function (* 'a list -> 'a result *)
  | x::_  -> return x
  | []    -> error "hd empty list"

let tl = function (* 'a list -> 'a list result *)
  | []    -> error "tl empty list"
  | _::xs -> return xs

let null = function (* 'a list -> bool result *)
  | []  -> return true
  | _   -> return false


let rec length xs = (* 'a list -> int result *)
  match null xs with
  | Ok true  -> Ok 0
  | Ok false -> 
      ( match tl xs with
      | Ok  xs  -> 
          ( match length xs with
          | Ok n      -> Ok (n+1)
          | Error msg -> Error msg
          )
      | Error msg   -> Error msg
      )
  | Error msg    -> Error msg


end

module Error = struct
  

type 'a result 
  = Ok    of 'a
  | Error of string

let return x  = Ok x  (* could have also been named "ok" *)
let error msg = Error msg



let bind m f = (* 'a result -> ('a -> 'b result) -> 'b result *)
  match m with 
  | Ok x      -> f x
  | Error msg -> Error msg

let (>>=) = bind (* left associative *)


let hd = function (* 'a list -> 'a result *)
  | x::_  -> return x
  | []    -> error "hd empty list"

let tl = function (* 'a list -> 'a list result *)
  | []    -> error "tl empty list"
  | _::xs -> return xs

let null = function (* 'a list -> bool result *)
  | []  -> return true
  | _   -> return false


let rec length xs = (* 'a list -> int result *)
  null xs >>= fun zero ->
  if zero then 
    return 0
  else 
    tl xs >>= fun xs' ->
    length xs' >>= fun n ->
    return (n+1)

let rec length xs = (* 'a list -> int result *)
  null xs >>= function
  | true  -> return 0
  | false ->
    tl xs >>= fun xs' ->
    length xs' >>= fun n ->
    return (n+1)

let rec length = function (* 'a list -> int result *)
  | []    -> return 0
  | _::xs -> length xs >>= fun n -> return (n+1)


end

module Classic = struct
  
let rec length = function (* 'a list -> int *)
  | []    -> 0
  | x::xs -> 1 + length xs


end