Kleisli List Arrow Combinators

// Kleisli List Arrow

// ( >>= ) : 'a list -> ('a -> 'b list) -> 'b list

let (>>=) m f = m |> List.map f |> List.concat

// unit : 'a -> 'a list

let unit x = [x]

type Arrow<'i,'o> = Arrow of('i -> 'o list)

// arr : ('a -> 'b list) -> Arrow<'a,'b>

let arr f = Arrow f

// pure' : ('a -> 'b) -> Arrow<'a,'b>

let pure' f = arr (unit << f)

// ( >>>> ) : Arrow<'a,'b> -> Arrow<'b,'c> -> Arrow<'a,'c>
let (>>>>) (Arrow f) (Arrow g) = arr ((fun m -> m >>= g) << f)

// first : Arrow<'a,'b> -> Arrow<('a * 'c),('b * 'c)>
let first (Arrow f) = arr (fun(x,y) -> (f x) >>= (fun x' -> unit (x', y)))

// second : Arrow<'a,'b> -> Arrow<('c * 'a),('c * 'b)>

let second (Arrow f) = arr (fun(x,y) -> (f y) >>= (fun y' -> unit (x, y')))


// mapA : Arrow<'a,'b> -> ('b -> 'c) -> Arrow<'a,'c>
// Not sure about this one. Is it right ?
let mapA m f = m >>>> pure' f

// toMonad : Arrow<unit,'a> -> 'a list

let toMonad (Arrow f) = f()

// map : 'a list -> ('a -> 'b) -> 'b list
let map m f = mapA (arr (fun _ -> m)) f |> toMonad

// bind : 'a list -> ('a -> 'b list) -> 'b list

let bind m f = (arr (fun _ -> m) >>>> arr f) |> toMonad

// fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b

let rec fix f x = f (fix f) x

// mfix : ('a -> 'a list) -> 'a list
// This one is wrong. Help!

let rec mfix f = match fix (fun x -> fun () -> f(List.head (x()))) () with

                 | [] -> []

                 | x::_ -> x :: mfix (List.tail<< f)

// liftM : ('a -> 'b) -> 'a list -> 'b list

let liftM f m = m >>= (fun a -> unit (f a))

// loop : Arrow<('a * 'b),('c * 'b)> -> Arrow<'a,'c>

let loop (Arrow f) = let f' x y = f (x, snd y)

                     arr (liftM fst << mfix << f')