Monad

monad.fs

namespace Hkt

/// 'F applied to 'A — the moral equivalent of 'F<'A>
[<AbstractClass>]
type App<'F, 'A>() = class end

type private App1<'F, 'A, 'Concrete>(value: 'Concrete) =
    inherit App<'F, 'A>()
    member _.Value = value

// Brands
type OptionBrand = class end
type ListBrand = class end
type ResultBrand<'E> = class end
type AsyncBrand = class end

[<RequireQualifiedAccess>]
module App =

    let inline encode (x: 'C) : App<'F, 'A> = App1<'F, 'A, 'C>(x) :> _
    let inline decode (app: App<'F, 'A>) : 'C = (app :?> App1<'F, 'A, 'C>).Value

// Usage:
module Exp =
    let x : App<OptionBrand, int> = App.encode (Some 42)
    let v : int option            = App.decode x
    printf "%A" v

    let y : App<ListBrand, string> = App.encode ["a"; "b"]
    let w : string list             = App.decode y

// Your own type:
//   type MyBrand = class end
//   let z : App<MyBrand, int> = App.encode (MyThing 42)
//   let q : MyThing<int>      = App.decode z

module Example =



    // A typeclass: "things you can map and flatMap over"
    type Monad<'F> =
        abstract Pure: 'A -> App<'F, 'A>
        abstract Bind: App<'F, 'A> -> ('A -> App<'F, 'B>) -> App<'F, 'B>

    // Two instances — that's all the boilerplate

    let optionM =
        { new Monad<OptionBrand> with
            member _.Pure x = App.encode (Some x)
            member _.Bind ma f =
                match App.decode ma with
                | Some a -> f a
                | None   -> App.encode None }

    let listM =
        { new Monad<ListBrand> with
            member _.Pure x = App.encode [x]
            member _.Bind ma f =
                App.decode ma |> List.collect (fun a -> App.decode (f a)) |> App.encode }

    // ---------------------------------------------------------------
    // THE PAYOFF: one function, two completely different behaviours
    // ---------------------------------------------------------------

    /// Chess piece placement: pick a rank, pick a file, combine.
    /// With Option: fail-fast if any choice is None.
    /// With List:   enumerate all combinations (nondeterminism).
    let place (m: Monad<'F>) (ranks: App<'F, int>) (files: App<'F, char>) =
        m.Bind ranks (fun r ->
            m.Bind files (fun f ->
                m.Pure (sprintf "%c%d" f r)))

    // -- Option: fail-fast --

    let r1 : string option =
        place optionM
            (App.encode (Some 1))
            (App.encode (Some 'e'))
        |> App.decode
    // Some "e1"

    let r2 : string option =
        place optionM
            (App.encode None)
            (App.encode (Some 'e'))
        |> App.decode
    // None

    // -- List: all combinations --

    let r3 : string list =
        place listM
            (App.encode [1; 2])
            (App.encode ['e'; 'd'])
        |> App.decode
    // ["e1"; "d1"; "e2"; "d2"]