Traversable Laws in F#

Traversable.Laws.fs

(*

Traversable Laws in F#
Ref: https://en.wikibooks.org/wiki/Haskell/Traversable#The_Traversable_laws

Note: 
- Install FSharpx.Extras, FsCheck.x, FsUnit.xUnit, FsCheck.Xunit

*)
 
module Traversable.Tests

open FSharpx
open FSharpx.Functional
open FsCheck
open global.Xunit

type Identity<'T> = 
    | Identity of (unit -> 'T)

module Identity = 
    let returnM a =
        Identity (fun () -> a)

    let map f idA = 
        let innerFn() = 
            let (Identity(idA)) = idA
            ()
            |> idA
            |> f
        Identity innerFn
    
    let apply ((Identity f): Identity<'a -> 'b>) ((Identity a): Identity<'a>) : Identity<'b> =
        Identity (fun () -> f() <| a())

let runIdentity idX = 
    let (Identity innerFn) = idX
    innerFn()

type ``Compose Async Option``<'a> = 
    | Compose of Async<Option<'a>>

module ``Compose Async Option`` =

    let map (f: 'a -> 'b) (Compose(rc): ``Compose Async Option``<'a>): ``Compose Async Option``<'b> =
        Async.map (Option.map f) rc |> Compose

    let retn (a: 'a): ``Compose Async Option``<'a> =
        a |> Option.returnM |> Async.returnM |> Compose
    
    let apply (Compose (f): ``Compose Async Option``<'a -> 'b>) (Compose (a): ``Compose Async Option``<'a>) : ``Compose Async Option``<'b> =
        a
        |> (Async.map Option.(<*>) >> Async.(<*>)) f
        |> Compose

    let getCompose (c: ``Compose Async Option``<'a>): Async<Option<'a>> =
        let (Compose c) = c
        c

module List =
    // traverse Async
    let traverseAsyncA f list = 
        let (<*>) = Async.(<*>)
        let retn = Async.returnM

        let cons head tail = head :: tail
        let initState = retn []

        let folder head tail = 
            retn cons <*> (f head) <*> tail

        List.foldBack folder list initState

    // traverse Option
    let traverseOptionA f list = 
        let (<*>) = Option.(<*>)
        let retn = Option.returnM

        let cons head tail = head :: tail
        let initState = retn []

        let folder head tail = 
            retn cons <*> (f head) <*> tail

        List.foldBack folder list initState

    // traverse Identity
    let traverseIdentityA f list = 
        let (<*>) = Identity.apply
        let retn = Identity.returnM

        let cons head tail = head :: tail
        let initState = retn []

        let folder head tail = 
            retn cons <*> (f head) <*> tail

        List.foldBack folder list initState

    // traverse Compose
    let traverseComposeA f list = 
        let (<*>) = ``Compose Async Option``.apply
        let retn = ``Compose Async Option``.retn

        let cons head tail = head :: tail
        let initState = retn []

        let folder head tail = 
            retn cons <*> (f head) <*> tail

        List.foldBack folder list initState

let unwrap = Async.RunSynchronously

[<Fact>]
let ``Traversable Law 1 - Identity`` () =
    // traverse Identity = Identity -- identity
    let law l =
        let rhs = List.traverseIdentityA Identity.returnM
        let lhs = Identity.returnM
        
        runIdentity (rhs l) = runIdentity (lhs l)

    Check.QuickThrowOnFailure law

[<Fact>]
let ``Traversable Law 2 - Composition`` () =
    // traverse (Compose . fmap g . f) = Compose . fmap (traverse g) . traverse f -- composition

    let getCompose = ``Compose Async Option``.getCompose
    let law l = 
        let rhs = Compose << Async.map (List.traverseOptionA Option.returnM) << List.traverseAsyncA Async.returnM
        let rv = rhs l
        let r = getCompose rv

        let lhs = List.traverseComposeA (Compose << Async.map Option.returnM << Async.returnM)
        let lv = lhs l
        let l = getCompose lv

        unwrap r = unwrap l

    Check.QuickThrowOnFailure law