Free monad interpreter in F# (based on: http://programmers.stackexchange.com/a/242803/145941)

Free.fsx

type DSL<'next> =
    | Get of string * (string -> 'next)
    | Set of string * string * 'next
    | End
    with static member fmap f = function
                | Get (k, c)    -> Get (k, f << c)
                | Set (k, v, c) -> Set (k, v, f c)
                | End           -> End

type FreeDSL<'a> =
    | Free   of DSL<FreeDSL<'a>>
    | Return of 'a
    with static member fmap f x =
            let rec go = function
                | Return a -> Return (f a)
                | Free  fa -> Free (DSL<FreeDSL<'a>>.fmap go fa)
            go x

let ex1 = Set ("alma", "bela", (Get ("alma", (fun s -> End))))
let exF1 = Free (Set ("alma", "bela", (Free (Get ("alma", (fun s -> Return End))))))

let flip f a b = f b a

let rec bindFreeDSL<'a, 'b> (ma : FreeDSL<'a>) (f : 'a -> FreeDSL<'b>) =
    match ma with
    | Return x -> f x
    | Free dsl -> Free (DSL<FreeDSL<'a>>.fmap ((flip bindFreeDSL) f) dsl)

type FreeDSLBuilder () =
    member this.Return = Return
    member this.ReturnFrom x = x
    member this.Bind (ma, f) = bindFreeDSL ma f

let domain = FreeDSLBuilder ()

let liftFreeDSL (action : DSL<'a>) = Free (DSL<FreeDSL<'a>>.fmap Return action)

let get key       = liftFreeDSL (Get (key, id))
let set key value = liftFreeDSL (Set (key, value, ()))
let end'<'a>      = liftFreeDSL End

let exF2 = domain.Bind(set "foo" "bar", (fun _ -> get "foo"))

let app<'a> = domain {
    do! set "foo" "bar"
    let! value = get "foo"
    do! set "x" value
    return! end'
}

// val it : FreeDSL<obj> =
//   Free (Set ("foo","bar",Free (Get ("foo",<fun:fmap@11-1>))))




[<AutoOpen>]
module Auth =
    
    type ConsumerData = { Name : string; Locale : string }
    type ConsumerDomainModel = { Name : string ; IsActive : bool }
    type ConsumerId = ConsumerId of string
    type AuthDSL<'next> =
        | GetConsumer of ConsumerId * (Option<ConsumerDomainModel> -> 'next)
        | Activate of ConsumerDomainModel * 'next
      //  | AcccptTerms of Consumer * (Consumer -> 'next)
      //  | ConnectWithFacebook of Consumer * (Consumer -> 'next)
      //  | CreateConsumer of ConsumerData * (Consumer -> 'next)
        | Commit
        with static member fmap f = function
            | GetConsumer (cId, next)   -> GetConsumer (cId, f << next)
            | Activate (consumer, next) -> Activate (consumer, f next)
            | Commit                    ->  Commit

    type FreeAuthDSL<'a> =
        | Free   of AuthDSL<FreeAuthDSL<'a>>
        | Return of 'a
        with static member fmap f x =
                let rec go = function
                    | Return a -> Return (f a)
                    | Free  fa -> Free (AuthDSL<FreeAuthDSL<'a>>.fmap go fa)
                go x

    let rec bindFreeDSL<'a, 'b> (ma : FreeAuthDSL<'a>) (f : 'a -> FreeAuthDSL<'b>) =
        match ma with
        | Return x -> f x
        | Free dsl -> Free (AuthDSL<FreeAuthDSL<'a>>.fmap ((flip bindFreeDSL) f) dsl)

    let liftFreeDSL (action : AuthDSL<'a>) = Free (AuthDSL<FreeAuthDSL<'a>>.fmap Return action)

    type AuthDSLBuilder () =
        member this.Return = Return
        member this.ReturnFrom x = x
        member this.Bind (ma, f) = bindFreeDSL ma f

    let auth = AuthDSLBuilder ()


    let getConsumer consumerId = liftFreeDSL (GetConsumer (consumerId, id))
    let activate consumer = liftFreeDSL (Activate (consumer, ()))
    let commit<'a> = liftFreeDSL Commit

    let authApp<'a> = 
        auth {
            let consumerId = ConsumerId "dingo"
            let! consumer = getConsumer consumerId 
            match consumer with
            | None -> return! commit
            | Some c -> do! activate c
                        return! commit
        }

    type Database = 
        { LookupById : ConsumerId -> Option<ConsumerDomainModel>
          Activate   : ConsumerDomainModel -> unit }

    let rec execute program (consumer : Option<ConsumerDomainModel>) (database : Database) =
        match program with
        | Free Commit -> consumer
        | Free (GetConsumer (consumerId, next)) -> 
            let consumer = database.LookupById consumerId
            execute (next consumer) consumer database
        | Free (Activate (consumer, next)) -> 
            database.Activate consumer
            let cnext = { consumer with IsActive = true }
            execute next (Some cnext) database
        | Return value -> value


    let simpleDatabase = 
        let lookup id =
            Some { Name = "dingo"; IsActive = false }
        let activate _ = ()
        { LookupById = lookup 
          Activate = activate }

module SeqAuth =
    type AuthOp =
        | GetConsumer of ConsumerId
        | Activate
    
    let consumerId = ConsumerId "dingo"
    let program = 
        seq {
            let consumer = GetConsumer consumerId
            yield GetConsumer consumerId
            yield Activate
        }
      
[<EntryPoint>]
let main argv = 
    printfn "%A" argv



    let result = execute authApp None simpleDatabase

    //prettyPrint stringApp
    0 // return an integer exit code