traverse-sequence.fsx

type Result<'a> = 
    | Success of 'a
    | Failure of string list


module Result = 

    let map f xResult = 
        match xResult with
        | Success x ->
            Success (f x)
        | Failure errs ->
            Failure errs

    let retn x = 
        Success x

    let apply fResult xResult = 
        match fResult,xResult with
        | Success f, Success x ->
            Success (f x)
        | Failure errs, Success x ->
            Failure errs
        | Success f, Failure errs ->
            Failure errs
        | Failure errs1, Failure errs2 ->
            Failure (List.concat [errs1; errs2])

    let bind f xResult = 
        match xResult with
        | Success x ->
            f x
        | Failure errs ->
            Failure errs
    
module Async = 

    let map f xAsync = async {
        // get the contents of xAsync 
        let! x = xAsync 
        // apply the function and lift the result
        return f x
        }

    let retn x = async {
        // lift x to an Async
        return x
        }

    let apply fAsync xAsync = async {
        // start the two asyncs in parallel
        let! fChild = Async.StartChild fAsync
        let! xChild = Async.StartChild xAsync

        // wait for the results
        let! f = fChild
        let! x = xChild 

        // apply the function to the results
        return f x 
        }

    let bind f xAsync = async {
        // get the contents of xAsync 
        let! x = xAsync 
        // apply the function but don't lift the result
        // as f will return an Async
        return! f x
        }

module List =

    let rec traverseResultA f list =
        let (<*>) = Result.apply
        let retn = Result.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 rec traverseResultM f list =
        let (>>=) x f = Result.bind f x
        let retn = Result.retn
        let cons head tail = head :: tail
        let initState = retn []
        let folder head tail = 
            f head >>= (fun h -> 
            tail >>= (fun t ->
            retn (cons h t) ))
        List.foldBack folder list initState 

    let rec traverseAsyncA f list =
        let (<*>) = Async.apply
        let retn = Async.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 rec traverseAsyncM f list =
        let (>>=) x f = Async.bind f x
        let retn = Async.retn
        let cons head tail = head :: tail
        let initState = retn []
        let folder head tail = 
            f head >>= (fun h -> 
            tail >>= (fun t ->
            retn (cons h t) ))
        List.foldBack folder list initState 

    let sequenceResultA x = traverseResultA id x

    let sequenceResultM x = traverseResultM id x

    let sequenceAsyncA x = traverseAsyncA id x

    let sequenceAsyncM x = traverseAsyncM id x


type [<Measure>] ms

type WebClientWithTimeout(timeout:int<ms>) =
    inherit System.Net.WebClient()

    override this.GetWebRequest(address) =
        let result = base.GetWebRequest(address)
        result.Timeout <- int timeout 
        result

type UriContent = 
    UriContent of System.Uri * string

type UriContentSize = 
    UriContentSize of System.Uri * int

let getUriContent (uri:System.Uri) = 
    async {
        use client = new WebClientWithTimeout(1000<ms>) // 1 sec timeout
        try
            printfn "  [%s] Started ..." uri.Host
            let! html = client.AsyncDownloadString(uri) 
            printfn "  [%s] ... finished" uri.Host
            let uriContent = UriContent (uri, html)
            return (Success uriContent)
        with
        | ex -> 
            printfn "  [%s] ... exception" uri.Host
            let err = sprintf "[%s] %A" uri.Host ex.Message
            return Failure [err ]
        }

let showContentResult result =
    match result with
    | Success (UriContent (uri, html)) -> 
        printfn "SUCCESS: [%s] First 100 chars: %s" uri.Host (html.Substring(0,100)) 
    | Failure errs -> 
        printfn "FAILURE: %A" errs

System.Uri ("http://example.bad") 
|> getUriContent 
|> Async.RunSynchronously 
|> showContentResult


let makeContentSize (UriContent (uri, html)) = 
    if System.String.IsNullOrEmpty(html) then
        Failure ["empty page"]
    else
        let uriContentSize = UriContentSize (uri, html.Length)
        Success uriContentSize 

let getUriContentSize uri =
    getUriContent uri 
    |> Async.map (Result.bind makeContentSize)

let showContentSizeResult result =
    match result with
    | Success (UriContentSize (uri, len)) -> 
        printfn "SUCCESS: [%s] Content size is %i" uri.Host len 
    | Failure errs -> 
        printfn "FAILURE: %A" errs

System.Uri ("http://google.com") 
|> getUriContentSize 
|> Async.RunSynchronously 
|> showContentSizeResult 

let maxContentSize list = 
    let contentSize (UriContentSize (_, len)) = len
    list |> List.maxBy contentSize 

let largestPageSizeA urls = 
    urls
    // turn the list of strings into a list of Uris
    // (In F# v4, we can call System.Uri directly!)
    |> List.map (fun s -> System.Uri(s))   
    
    // turn the list of Uris into a "Async<Result<UriContentSize>> list" 
    |> List.map getUriContentSize
    
    // turn the "Async<Result<UriContentSize>> list" 
    //   into an "Async<Result<UriContentSize> list>"
    |> List.sequenceAsyncA
    
    // turn the "Async<Result<UriContentSize> list>" 
    //   into a "Async<Result<UriContentSize list>>"
    |> Async.map List.sequenceResultA
    
    // find the largest in the inner list to get 
    //   a "Async<Result<UriContentSize>>"
    |> Async.map (Result.map maxContentSize)

let time countN label f  = 

    let stopwatch = System.Diagnostics.Stopwatch()
    
    // do a full GC at the start but not thereafter
    // allow garbage to collect for each iteration
    System.GC.Collect()  

    printfn "======================="         
    printfn "%s" label 
    printfn "======================="         
    
    let mutable totalMs = 0L

    for iteration in [1..countN] do
        stopwatch.Restart() 
        f()
        stopwatch.Stop() 
        printfn "#%2i elapsed:%6ims " iteration stopwatch.ElapsedMilliseconds 
        totalMs <- totalMs + stopwatch.ElapsedMilliseconds

    let avgTimePerRun = totalMs / int64 countN
    printfn "%s: Average time per run:%6ims " label avgTimePerRun 

let goodSites = [
    "http://google.com"
    "http://bbc.co.uk"
    "http://fsharp.org"
    "http://microsoft.com"
    ]

let badSites = [
    "http://example.com/nopage"
    "http://bad.example.com"
    "http://verybad.example.com"
    "http://veryverybad.example.com"
    ]


let largestPageSizeM urls = 
    urls
    |> List.map (fun s -> System.Uri(s))
    |> List.map getUriContentSize
    |> List.sequenceAsyncM              // <= "M" version
    |> Async.map List.sequenceResultM   // <= "M" version
    |> Async.map (Result.map maxContentSize)


let f() = 
    largestPageSizeM badSites
    |> Async.RunSynchronously 
    |> showContentSizeResult 
//time 5 "largestPageSizeA_Good" f

/// type alias (optional)
type AsyncResult<'a> = Async<Result<'a>>

/// functions for AsyncResult 
module AsyncResult =

    let map f = 
        f |> Result.map |> Async.map 

    let retn x = 
        x |> Result.retn |> Async.retn

    let apply fAsyncResult xAsyncResult = 
        fAsyncResult |> Async.bind (fun fResult -> 
        xAsyncResult |> Async.map (fun xResult -> 
        Result.apply fResult xResult))

    let bind f xAsyncResult = async {
        let! xResult = xAsyncResult 
        match xResult with
        | Success x -> return! f x
        | Failure err -> return (Failure err)
        }