comnads in fsharp

comonad.fsx

//extend :: (w a -> b) -> w a -> w b
//duplicate :: w a -> w (w a)
//extract :: w a -> a

module CoReader =
    type CoReader<'e, 'a> = CoReader of  env : 'e * value : 'a
    let askC (CoReader(env, _)) = env
    let extract (CoReader(_, value)) = value
    let extend f w = CoReader(askC w, f w)
    let duplicate w = extend id w
    let fmap f = extend (f << extract)

[<AutoOpen>]
module Monoid =
    type Monoid<'a> = MonoidOps of mzero: 'a * mappend : ('a -> 'a -> 'a)
    let mZero (MonoidOps(z,_)) = z
    let mAppend (MonoidOps(_, append)) a b = append a b

[<AutoOpen>]
module StringMonoid =
    type System.String with
        static member MonoidOps () = MonoidOps("", fun (a:string) (b:string) -> a + b) 

module CoWriter = //aka Traced comonad
    type CoWriter<'e,'a> = CoWriter of ('e -> 'a) * Monoid<'e>
    let fmap f (CoWriter(g, m)) = CoWriter (f << g, m)
    let extract (CoWriter(m, monoid)) = m <| Monoid.mZero monoid
    let duplicate (CoWriter (g, monoid)) = 
        let mappend = Monoid.mAppend monoid 
        CoWriter((fun w' -> CoWriter ((fun w -> g (mappend w w')), monoid)), monoid)
    let extend f = fmap f << duplicate
  
module Store =
    type Store<'s,'a> = Store of peek : ('s -> 'a) * pos : 's 
    let seek (Store(peek,_)) s = Store(peek, s) 
    let fmap f (Store(peek,pos)) = Store(peek >> f, pos) 
    let extract (Store(peek,pos)) = peek(pos)
    let duplicate (Store(peek,pos)) = Store((fun pos -> Store(peek, pos)), pos) 
    let extend f  = fmap f << duplicate

    type Lens<'s,'a> = 'a -> Store<'s,'a>

module Stream =
    let force (value : Lazy<_>) = value.Force()
    type Stream<'a> = Cons of 'a * Lazy<Stream<'a>>
    let rec fmap f (Cons (h, t)) = Cons (f h, lazy ( fmap f <| force t ))
    let extract (Cons(x,_)) = x
    let rec duplicate xs =
        let (Cons(_, xs')) = xs
        Cons(xs, lazy ( duplicate <| force xs'))
    let rec extend f xs =
        let (Cons(_, xs')) = xs
        Cons(f xs, lazy ( extend f <| force xs'))

module Zipper=
    type Z<'a> = Z of 'a list * 'a * 'a list
    let right z = 
        match z with
            | Z(ls,a,r::rs) -> Z(a::ls, r, rs) 
            | _ -> z
    let left z = 
        match z with
            | Z(l::ls,a,rs) -> Z(ls, l, a::rs) 
            | _ -> z

    let rec fmap f (Z(l,a,r)) =
        Z(List.map f l,f a, List.map f r)

    let rec iterate f a =
        let next = f a
        next :: (iterate f next) 

    let extract (Z(_,a,_)) = a
    let duplicate z = Z(iterate left z, z, iterate right z)
    let extend f z = Z (List.map f <| iterate left z, f z, List.map f <| iterate right z)

module CArray =
    type CArray<'a> = CA of 'a array  * int
    let fmap f (CA(a, i)) = CA(Array.map f a, i)
    let extract (CA(a, i)) = a.[i]
    let extend f (CA(a, i)) = 
        let es' = Array.mapi (fun i _ -> f (CA(a,i))) a 
        in CA(es',i)