Code examples from fsharpforfunandprofit.com/posts/dependencies-4/

DependencyInterpretation.fsx

(* ===================================
Code from my series of posts "Six approaches to dependency injection"
=================================== *)

open System


(* ======================================================================
5. Dependency Interpretation

In which we create a data structure and then interpret it later
====================================================================== *)


//----------------------------------------
// Version 1 - a bad attempt to return commands
//----------------------------------------

module ReadFromConsole_v1 =

    type Instruction =
        | ReadLn
        | WriteLn of string

    let readFromConsole() = 
        let cmd1 = WriteLn "Enter the first value"
        let cmd2 = ReadLn
        let cmd3 = WriteLn "Enter the second value"
        let cmd4 = ReadLn

        // return all the instructions I want the I/O part to do
        [cmd1; cmd2; cmd3; cmd4]

// doesn't compile!
(*
    let interpretInstruction instruction =
        match instruction with
        | ReadLn -> Console.ReadLine()
        | WriteLn str -> printfn "%s" str  
  
*)


//----------------------------------------
// Version 2 - a correct attempt to using a Program structure
//----------------------------------------

module ReadFromConsole_v2 =

    
    // normal ReadLn is  unit -> string
    // it becomes        unit * (string -> Program)
    //
    // normal WriteLn is string -> unit
    // it becomes        string * (unit -> Program)

    type Program<'a> =
        //           input to        output of 
        //           interpreter     interpreter
        | ReadLn  of unit    * next:(string    -> Program<'a>)
        | WriteLn of string  * next:(unit      -> Program<'a>)
        | Stop    of 'a

    let readFromConsole = 
        WriteLn ("Enter the first value" , fun () ->
        ReadLn  ( ()                     , fun str1 ->
        WriteLn ("Enter the second value", fun () ->
        ReadLn  ( ()                     , fun str2 ->
        Stop  (str1,str2)        // no "next" function
        ))))
        
    let rec interpret program =
        match program with
        | ReadLn ((), next) -> 
            // 1. interpret the meaning of "ReadLn" to do actual I/O
            let str = Console.ReadLine()
            // 2. call "next" with the output of the interpretation.
            // This gives us another Program
            let nextProgram = next str 
            // 3. interpret the new Program (recursively)
            interpret nextProgram   
        | WriteLn (str,next) -> 
            printfn "%s" str
            let nextProgram = next()
            interpret nextProgram   
        | Stop value -> 
            // return the overall result of the Program
            value 
    
// test
(*
open ReadFromConsole_v2 
interpret readFromConsole
*)

//----------------------------------------
// Version 3 - Same as above, but using computation expressions
//----------------------------------------

module ReadFromConsole_v3 =
    open ReadFromConsole_v2 

    // same as before
    type Program<'a> = ReadFromConsole_v2.Program<'a>

    module Program =
        let rec bind f program = 
            match program with
            | ReadLn ((),next) -> ReadLn ((),next >> bind f)
            | WriteLn (str,next) -> WriteLn (str, next >> bind f)
            | Stop x -> f x

    type ProgramBuilder() =
        member __.Return(x) = Stop x 
        member __.Bind(x,f) = Program.bind f x
        member __.Zero() = Stop ()

    // the builder instance
    let program = ProgramBuilder()

    // helpers to use within the computation expression
    let writeLn str = WriteLn (str,Stop)
    let readLn() = ReadLn ((),Stop)

    let readFromConsole = program {
        do! writeLn "Enter the first value"
        let! str1 = readLn()  
        do! writeLn "Enter the second value"
        let! str2 = readLn()  
        return (str1,str2)
        }

    // same as before
    let interpret = ReadFromConsole_v2.interpret
    
// test
(*
open ReadFromConsole_v3 
interpret readFromConsole
*)


//----------------------------------------
// The complete mini-application
//----------------------------------------

module MiniApplication_v1 =


    // 1. Define the set of instructions we want to support
    type ConsoleInstruction<'a> =
        | ReadLn  of unit    * next:(string -> 'a)
        | WriteLn of string  * next:(unit   -> 'a)

    type LoggerInstruction<'a> =
        | LogDebug of string * next:(unit -> 'a)
        | LogInfo of string  * next:(unit -> 'a)

    type Program<'a> =
        | ConsoleInstruction of ConsoleInstruction<Program<'a>>
        | LoggerInstruction of LoggerInstruction<Program<'a>>
        | Stop of 'a

    // 2. Define a "map" for each group of instructions
    module ConsoleInstruction =
        let rec map f program = 
            match program with
            | ReadLn ((),next) -> ReadLn ((),next >> f)
            | WriteLn (str,next) -> WriteLn (str, next >> f)

    module LoggerInstruction =
        let rec map f program = 
            match program with
            | LogDebug (str,next) -> LogDebug (str,next >> f)
            | LogInfo (str,next) -> LogInfo (str,next >> f)

    // 3. Define the corresponding "bind" 
    module Program =
        let rec bind f program = 
            match program with
            | ConsoleInstruction inst -> 
                inst |> ConsoleInstruction.map (bind f) |> ConsoleInstruction 
            | LoggerInstruction inst -> 
                inst |> LoggerInstruction.map (bind f) |> LoggerInstruction 
            | Stop x -> 
                f x

    // 4. Define the computation expression
    type ProgramBuilder() =
        member __.Return(x) = Stop x 
        member __.Bind(x,f) = Program.bind f x
        member __.Zero() = Stop ()

    // the builder instance
    let program = ProgramBuilder()

    
    // 5. Define the interpreter
    let rec interpret program =

        let interpretConsole inst =
            match inst with
            | ReadLn ((), next) -> 
                let str = Console.ReadLine()
                interpret (next str)
            | WriteLn (str,next) -> 
                printfn "%s" str
                interpret (next())

        let interpretLogger inst =
            match inst with
            | LogDebug (str, next) -> 
                printfn "DEBUG %s" str
                interpret (next())
            | LogInfo (str, next) -> 
                printfn "INFO %s" str
                interpret (next())

        match program with
        | ConsoleInstruction inst -> interpretConsole inst
        | LoggerInstruction inst -> interpretLogger inst
        | Stop value -> value 

    // helpers to use within the computation expression
    let writeLn str = ConsoleInstruction (WriteLn (str,Stop))
    let readLn() = ConsoleInstruction (ReadLn ((),Stop))
    let logDebug str = LoggerInstruction (LogDebug (str,Stop))
    let logInfo str = LoggerInstruction (LogInfo (str,Stop))


    type ComparisonResult =
        | Bigger
        | Smaller
        | Equal

    let readFromConsole = program {
        do! writeLn "Enter the first value"
        let! str1 = readLn()  
        do! writeLn "Enter the second value"
        let! str2 = readLn()  
        return  (str1,str2)
        }

    let compareTwoStrings str1 str2 = program {
        do! logDebug "compareTwoStrings: Starting"

        let result =
            if str1 > str2 then
                Bigger
            else if str1 < str2 then
                Smaller
            else
                Equal

        do! logInfo (sprintf "compareTwoStrings: result=%A" result)
        do! logDebug "compareTwoStrings: Finished"
        return result 
        }


    let writeToConsole (result:ComparisonResult) = program {
        match result with
        | Bigger ->
            do! writeLn "The first value is bigger"
        | Smaller ->
            do! writeLn "The first value is smaller"
        | Equal ->
            do! writeLn "The values are equal"
        }


    let myProgram = program {
        let! str1, str2 = readFromConsole 
        let! result = compareTwoStrings str1 str2 
        do! writeToConsole result 
        }

(*
open MiniApplication_v1
interpret myProgram
*)


//----------------------------------------
// A generic program that does not know about specific instructions
//----------------------------------------

module GenericProgram =

    // 1. Define a instruction interface that contains a "map" 
    type IInstruction<'a> =
        abstract member Map : ('a->'b) -> IInstruction<'b> 

    // 2, Use the interface in the Program type
    type Program<'a> =
        | Instruction of IInstruction<Program<'a>>
        | Stop of 'a

    // 3. Define the corresponding "bind" 
    module Program =
        let rec bind f program = 
            match program with
            | Instruction inst -> 
                inst.Map (bind f) |> Instruction 
            | Stop x -> f x

    // 4. Define the computation expression
    type ProgramBuilder() =
        member __.Return(x) = Stop x 
        member __.Bind(x,f) = Program.bind f x
        member __.Zero() = Stop ()

    // and the builder instance
    let program = ProgramBuilder()

//----------------------------------------
// The complete mini-application, using the generic program approach
//----------------------------------------

module MiniApplication_v2 =

    open GenericProgram
    
    // to support a specific application:

    // 1. Define the set of instructions we want to support, and their map
    type ConsoleInstruction<'a> =
        | ReadLn  of unit    * next:(string -> 'a)
        | WriteLn of string  * next:(unit   -> 'a)
        interface IInstruction<'a> with
            member this.Map f  = 
                match this with
                | ReadLn ((),next) -> ReadLn ((),next >> f)
                | WriteLn (str,next) -> WriteLn (str, next >> f)
                :> IInstruction<_> 

    type LoggerInstruction<'a> =
        | LogDebug of string * next:(unit -> 'a)
        | LogInfo of string  * next:(unit -> 'a)
        interface IInstruction<'a> with
            member this.Map f  = 
                match this with
                | LogDebug (str,next) ->  LogDebug (str,next >> f)
                | LogInfo (str,next) ->  LogInfo (str,next >> f)
                :> IInstruction<_> 

    // 2. Define the interpreter

    // modular interpreter for ConsoleInstruction
    let interpretConsole interpret inst =
        match inst with
        | ReadLn ((), next) -> 
            let str = Console.ReadLine()
            interpret (next str)
        | WriteLn (str,next) -> 
            printfn "%s" str
            interpret (next())

    // modular interpreter for LoggerInstruction
    let interpretLogger interpret inst =
        match inst with
        | LogDebug (str, next) -> 
            printfn "DEBUG %s" str
            interpret (next())
        | LogInfo (str, next) -> 
            printfn "INFO %s" str
            interpret (next())

    // interpreter for this particular workflow
    let rec interpret program =
        match program with
        | Instruction inst ->
            match inst with
            | :? ConsoleInstruction<Program<_>> as i -> interpretConsole interpret i
            | :? LoggerInstruction<Program<_>> as i -> interpretLogger interpret i
            | _ -> failwithf "unknown instruction type %O" (inst.GetType())
        | Stop value -> value 

    // helpers to use within the computation expression
    let writeLn str = Instruction (WriteLn (str,Stop))
    let readLn() = Instruction (ReadLn ((),Stop))
    let logDebug str = Instruction (LogDebug (str,Stop))
    let logInfo str = Instruction (LogInfo (str,Stop))

    type ComparisonResult =
        | Bigger
        | Smaller
        | Equal

    let readFromConsole = program {
        do! writeLn "Enter the first value"
        let! str1 = readLn()  
        do! writeLn "Enter the second value"
        let! str2 = readLn()  
        return  (str1,str2)
        }

    let compareTwoStrings str1 str2 = program {
        do! logDebug "compareTwoStrings: Starting"

        let result =
            if str1 > str2 then
                Bigger
            else if str1 < str2 then
                Smaller
            else
                Equal

        do! logInfo (sprintf "compareTwoStrings: result=%A" result)
        do! logDebug "compareTwoStrings: Finished"
        return result 
        }

    let writeToConsole (result:ComparisonResult) = program {
        match result with
        | Bigger ->
            do! writeLn "The first value is bigger"
        | Smaller ->
            do! writeLn "The first value is smaller"
        | Equal ->
            do! writeLn "The values are equal"
        }


    let myProgram = program {
        let! str1, str2 = readFromConsole 
        let! result = compareTwoStrings str1 str2 
        do! writeToConsole result 
        }

(*
open MiniApplication_v2
interpret myProgram
*)

//----------------------------------------
// Demonstrates that this approach is modular
//----------------------------------------

module ModularityDemo =

    open GenericProgram
    open MiniApplication_v2

    type DbInstruction<'a> =
        | DbInsert of string  * next:(unit   -> 'a)
        interface IInstruction<'a> with
            member this.Map f  = 
                match this with
                | DbInsert (str,next) -> DbInsert (str, next >> f)
                :> IInstruction<_> 

    // helpers to use within the computation expression
    let dbInsert str = Instruction (DbInsert(str,Stop))
    
    let logStringsToDb str1 str2 = program {
        do! dbInsert str1
        do! dbInsert str2
        }

    let myProgram = program {
        let! str1, str2 = readFromConsole 
        do! logStringsToDb str1 str2 
        let! result = compareTwoStrings str1 str2 
        do! writeToConsole result 
        }
        
    // modular interpreter for LoggerInstruction
    let interpretDbInstruction interpret inst =
        match inst with
        | DbInsert (str, next) -> 
            printfn "DbInsert %s" str
            interpret (next())

    // interpreter for this particular workflow
    let rec interpret program =
        match program with
        | Instruction inst ->
            match inst with
            | :? ConsoleInstruction<Program<_>> as i -> interpretConsole interpret i
            | :? LoggerInstruction<Program<_>> as i -> interpretLogger interpret i
            | :? DbInstruction<Program<_>> as i -> interpretDbInstruction interpret i
            | _ -> failwithf "unknown instruction type %O" (inst.GetType())
        | Stop value -> value 

(*
open ModularityDemo
interpret myProgram
*)