6 people like it.

An Elmish pattern with centralized commands.

A useful pattern for I/O heavy or view-less apps. User defines an order type to use instead of Cmd<'msg> and an "execute" function processing said orders and dispatching message. It frees the update function from command code, centralizes I/O in a elmishy way and exempts from the Cmd module. Inspired by the CmdMsg pattern, see: https://fsprojects.github.io/Fabulous/Fabulous.XamarinForms/update.html#replacing-commands-with-command-messages-for-better-testability

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
66: 
67: 
68: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
81: 
82: 
83: 
84: 
85: 
86: 
87: 
88: 
89: 
//#r "nuget: Elmish,3.0.1"
open System
open Elmish

let description = "Count-o-matic : watch integers being counted on your console.
Press Space to start, pause or resume.
Press Enter to step while in pause.
Press +/- to increase/decrease speed while running.
Press Q to quit."

module Program =
    /// <summary>
    /// Program with user-defined orders instead of usual command.
    /// Orders are processed by <code>execute</code> which can dispatch messages,
    /// called in place of usual command processing.
    /// </summary>
    let mkProgramWithOrderExecute
            (init: 'arg' -> 'model * 'order)
            (update: 'msg -> 'model -> 'model * 'order)
            (view: 'model -> Dispatch<'msg> -> 'view)
            (execute: 'order -> Dispatch<'msg> -> unit) =
        let convert (model, cmdMsg) = 
            model, cmdMsg |> execute |> Cmd.ofSub 
        Program.mkProgram
            (init >> convert)
            (fun msg model -> update msg model |> convert)
            view

type Model = { Running: bool ; Count: int ; Interval: int }
type Msg = 
    | TimerTick
    | KeyboardTick
    | Toggle
    | ChangeInterval of offset: int
/// user-defined order type
type Order =
    | StartKeyListener
    | Print of value: int
    | DelayTick of delay: int
    | CancelDelay
    | Orders of Order list
    | NoOrder

let init (running, interval) =
    let model = { Running=running ; Count=0 ; Interval=interval }
    model, Orders [ StartKeyListener ; if running then DelayTick 0 ]
let update msg model =
    match msg, model.Running with
    | TimerTick, true
    | Toggle, false ->
        let model' = { model with Running = true; Count = model.Count+1 }
        model', Orders [ Print (model.Count+1) ; DelayTick model.Interval ]
    | Toggle, true ->
        { model with Running = false }, CancelDelay
    | KeyboardTick, false -> 
        { model with Count = model.Count+1 }, Print (model.Count+1)
    | ChangeInterval x, true ->
        { model with Interval = model.Interval+x |> min 2500 |> max 50 }, NoOrder
    | KeyboardTick, true | ChangeInterval _, false | TimerTick, false -> 
        model, NoOrder

/// Function executing orders, with a dispatch function as second argument.
let rec execute order dispatch =
    match order with
    | StartKeyListener ->
        async {
            seq { while true do (Console.ReadKey true).KeyChar }
            |> Seq.takeWhile (fun key -> key <> 'q' && key <> 'Q')  // press q to quit
            |> Seq.iter (function
                | ' ' -> dispatch Toggle
                | '\013' -> dispatch KeyboardTick   // Enter key
                | '-' -> dispatch (ChangeInterval 50)
                | '+' -> dispatch (ChangeInterval -50)
                | _ -> ())
            Async.CancelDefaultToken () }
        |> Async.StartImmediate
    | Print value -> Console.WriteLine value
    | DelayTick delay ->
        async { do! Async.Sleep delay
                dispatch TimerTick }
        |> Async.Start
    | CancelDelay -> Async.CancelDefaultToken ()
    | Orders orders -> for order in orders do execute order dispatch
    | NoOrder -> ()
let view _ _ = ()

Console.WriteLine description
Program.mkProgramWithOrderExecute init update view execute
|> Program.runWith (false, 350)
namespace System
namespace Elmish
val description : string
Multiple items
module Program

from Elmish

--------------------
type Program<'arg,'model,'msg,'view> =
  private { init: 'arg -> 'model * Cmd<'msg>
            update: 'msg -> 'model -> 'model * Cmd<'msg>
            subscribe: 'model -> Cmd<'msg>
            view: 'model -> Dispatch<'msg> -> 'view
            setState: 'model -> Dispatch<'msg> -> unit
            onError: string * exn -> unit
            syncDispatch: Dispatch<'msg> -> Dispatch<'msg> }
val mkProgramWithOrderExecute : init:('arg' -> 'model * 'order) -> update:('msg -> 'model -> 'model * 'order) -> view:('model -> Dispatch<'msg> -> 'view) -> execute:('order -> Dispatch<'msg> -> unit) -> Program<'arg','model,'msg,'view>


 <summary>
 Program with user-defined orders instead of usual command.
 Orders are processed by <code>execute</code> which can dispatch messages,
 called in place of usual command processing.
 </summary>
val init : ('arg' -> 'model * 'order)
val update : ('msg -> 'model -> 'model * 'order)
val view : ('model -> Dispatch<'msg> -> 'view)
type Dispatch<'msg> = 'msg -> unit
val execute : ('order -> Dispatch<'msg> -> unit)
type unit = Unit
val convert : ('a * 'order -> 'a * Cmd<'msg>)
val model : 'a
val cmdMsg : 'order
Multiple items
module Cmd

from Elmish

--------------------
type Cmd<'msg> = Sub<'msg> list
val ofSub : sub:Sub<'msg> -> Cmd<'msg>
val mkProgram : init:('arg -> 'model * Cmd<'msg>) -> update:('msg -> 'model -> 'model * Cmd<'msg>) -> view:('model -> Dispatch<'msg> -> 'view) -> Program<'arg,'model,'msg,'view>
val msg : 'msg
val model : 'model
type Model =
  { Running: bool
    Count: int
    Interval: int }
Model.Running: bool
type bool = Boolean
Model.Count: int
Multiple items
val int : value:'T -> int (requires member op_Explicit)

--------------------
type int = int32

--------------------
type int<'Measure> = int
Model.Interval: int
type Msg =
  | TimerTick
  | KeyboardTick
  | Toggle
  | ChangeInterval of offset: int
union case Msg.TimerTick: Msg
union case Msg.KeyboardTick: Msg
union case Msg.Toggle: Msg
union case Msg.ChangeInterval: offset: int -> Msg
type Order =
  | StartKeyListener
  | Print of value: int
  | DelayTick of delay: int
  | CancelDelay
  | Orders of Order list
  | NoOrder


 user-defined order type
union case Order.StartKeyListener: Order
union case Order.Print: value: int -> Order
union case Order.DelayTick: delay: int -> Order
union case Order.CancelDelay: Order
union case Order.Orders: Order list -> Order
type 'T list = List<'T>
union case Order.NoOrder: Order
val init : running:bool * interval:int -> Model * Order
val running : bool
val interval : int
val model : Model
val update : msg:Msg -> model:Model -> Model * Order
val msg : Msg
val model' : Model
val x : int
val min : e1:'T -> e2:'T -> 'T (requires comparison)
val max : e1:'T -> e2:'T -> 'T (requires comparison)
val execute : order:Order -> dispatch:(Msg -> unit) -> unit


 Function executing orders, with a dispatch function as second argument.
val order : Order
val dispatch : (Msg -> unit)
val async : AsyncBuilder
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

--------------------
type seq<'T> = Collections.Generic.IEnumerable<'T>
type Console =
  static member BackgroundColor : ConsoleColor with get, set
  static member Beep : unit -> unit + 1 overload
  static member BufferHeight : int with get, set
  static member BufferWidth : int with get, set
  static member CapsLock : bool
  static member Clear : unit -> unit
  static member CursorLeft : int with get, set
  static member CursorSize : int with get, set
  static member CursorTop : int with get, set
  static member CursorVisible : bool with get, set
  ...
Console.ReadKey() : ConsoleKeyInfo
Console.ReadKey(intercept: bool) : ConsoleKeyInfo
module Seq

from Microsoft.FSharp.Collections
val takeWhile : predicate:('T -> bool) -> source:seq<'T> -> seq<'T>
val key : char
val iter : action:('T -> unit) -> source:seq<'T> -> unit
Multiple items
type Async =
  static member AsBeginEnd : computation:('Arg -> Async<'T>) -> ('Arg * AsyncCallback * obj -> IAsyncResult) * (IAsyncResult -> 'T) * (IAsyncResult -> unit)
  static member AwaitEvent : event:IEvent<'Del,'T> * ?cancelAction:(unit -> unit) -> Async<'T> (requires delegate and 'Del :> Delegate)
  static member AwaitIAsyncResult : iar:IAsyncResult * ?millisecondsTimeout:int -> Async<bool>
  static member AwaitTask : task:Task -> Async<unit>
  static member AwaitTask : task:Task<'T> -> Async<'T>
  static member AwaitWaitHandle : waitHandle:WaitHandle * ?millisecondsTimeout:int -> Async<bool>
  static member CancelDefaultToken : unit -> unit
  static member Catch : computation:Async<'T> -> Async<Choice<'T,exn>>
  static member Choice : computations:seq<Async<'T option>> -> Async<'T option>
  static member FromBeginEnd : beginAction:(AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
  ...

--------------------
type Async<'T> =
static member Async.CancelDefaultToken : unit -> unit
static member Async.StartImmediate : computation:Async<unit> * ?cancellationToken:Threading.CancellationToken -> unit
val value : int
Console.WriteLine() : unit
   (+0 other overloads)
Console.WriteLine(value: string) : unit
   (+0 other overloads)
Console.WriteLine(value: obj) : unit
   (+0 other overloads)
Console.WriteLine(value: uint64) : unit
   (+0 other overloads)
Console.WriteLine(value: int64) : unit
   (+0 other overloads)
Console.WriteLine(value: uint32) : unit
   (+0 other overloads)
Console.WriteLine(value: int) : unit
   (+0 other overloads)
Console.WriteLine(value: float32) : unit
   (+0 other overloads)
Console.WriteLine(value: float) : unit
   (+0 other overloads)
Console.WriteLine(value: decimal) : unit
   (+0 other overloads)
val delay : int
static member Async.Sleep : millisecondsDueTime:int -> Async<unit>
static member Async.Start : computation:Async<unit> * ?cancellationToken:Threading.CancellationToken -> unit
val orders : Order list
val view : 'a -> 'b -> unit
Multiple items
module Program

from Script

--------------------
module Program

from Elmish

--------------------
type Program<'arg,'model,'msg,'view> =
  private { init: 'arg -> 'model * Cmd<'msg>
            update: 'msg -> 'model -> 'model * Cmd<'msg>
            subscribe: 'model -> Cmd<'msg>
            view: 'model -> Dispatch<'msg> -> 'view
            setState: 'model -> Dispatch<'msg> -> unit
            onError: string * exn -> unit
            syncDispatch: Dispatch<'msg> -> Dispatch<'msg> }
val runWith : arg:'arg -> program:Program<'arg,'model,'msg,'view> -> unit
Next Version Raw view Test code New version

More information

Link:http://fssnip.net/80F
Posted:3 years ago
Author:Julien Di Lenarda
Tags: elmish