12 people like it.

Miss Grant's Controller Parser

State machine example, from Martin Fowler's Domain-Specific Languages book, implemented as an External DSL parser in F#. A set of mutually recursive functions are used to parse the string tokens and build the State Machine as an F# record type.

  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: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
// Miss Grant's Controller External DSL with F# parser
// See Domain-Specific Languages: An Introductory Example by Martin Fowler
// http://www.informit.com/articles/article.aspx?p=1592379&seqNum=3

/// Name type abbreviation
type name = string
/// Code type abbreviation
type code = string

/// State Machine record type
type Machine = { 
    events : (name * code) list
    resetEvents: name list
    commands : (name * code) list
    states : (name * State) list
    } with 
    static member empty =
        { events = []; resetEvents = []; commands = []; states = [] }
and State = { actions: name list; transitions: (name * name) list }
    with static member empty = { actions=[]; transitions=[] }
     
let whitespace = " \t\r\n".ToCharArray()
let parseError s = invalidOp s

/// Returns new machine with values parsed from specified text
let rec parse (machine:Machine) = function
    | "events"::xs -> events machine xs
    | "resetEvents"::xs -> resetEvents machine xs
    | "commands"::xs -> commands machine xs
    | "state"::name::xs -> 
        let state',xs = parseState (State.empty) xs
        let machine' = { machine with states = (name,state')::machine.states }
        parse machine' xs
    | [] -> machine
    | x::_ -> "unknown token " + x |> parseError
/// Parses event declarations until end token is reached
and events machine = function
    | "end"::xs -> parse machine xs
    | name::code::xs -> 
        let event = (name,code)
        let machine' = { machine with events = event::machine.events }
        events machine' xs
    | _ -> parseError "events"
/// Parses reset event declarations until end token is reached
and resetEvents machine = function
    | "end"::xs -> parse machine xs
    | name::xs -> 
        let machine' = { machine with resetEvents = name::machine.resetEvents }
        resetEvents machine' xs
    | _ -> parseError "resetEvents"
/// Parses command declarations until end token is reached
and commands machine = function
    | "end"::xs -> parse machine xs
    | name::code::xs ->
        let command = (name,code)
        let machine' = { machine with commands = command::machine.commands }
        commands machine' xs
    | _ -> parseError "commands"
/// Parses state declaration until end token is reached
and parseState state = function
    | "end"::xs -> state,xs
    | "actions"::xs ->
        let actions', xs = actions xs  
        let state' = { state with actions = actions'@state.actions }
        parseState state' xs
    | event::"=>"::action::xs ->        
        let transition = (event,action)
        let state' = { state with transitions = transition::state.transitions }
        parseState state' xs 
    | _ -> parseError "state"
/// Parses action names in curly braces
and actions (xs:string list) = 
    /// Returns text inside curly braces scope
    let rec scope acc = function
        | (x:string)::xs when x.Contains("}") -> 
            (String.concat " " (List.rev (x::acc))).Trim([|'{';'}'|]), xs
        | x::xs -> scope (x::acc) xs
        | [] -> invalidOp "scope"
    let s, xs = scope [] xs
    s.Split(whitespace) |> Array.toList, xs

/// DSL specification
let text = "
events
 doorClosed D1CL
 drawerOpened D2OP
 lightOn L1ON
 doorOpened D1OP
 panelClosed PNCL end
 
resetEvents
 doorOpened 
end

commands
 unlockPanel PNUL
 lockPanel PNLK
 lockDoor D1LK
 unlockDoor D1UL
end 	

state idle	
 actions {unlockDoor lockPanel}
 doorClosed => active 
end 

state active
 drawerOpened => waitingForLight
 lightOn => waitingForDrawer 
end 

state waitingForLight
 lightOn => unlockedPanel 
end 

state waitingForDrawer
 drawerOpened => unlockedPanel 
end 

state unlockedPanel
 actions {unlockPanel lockDoor}
 panelClosed => idle 
end"

/// Machine built from DSL text
let machine =
    text.Split(whitespace, System.StringSplitOptions.RemoveEmptyEntries)
    |> Array.toList
    |> parse Machine.empty
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
type code = string

Full name: Script.code


 Code type abbreviation
type Machine =
  {events: (name * code) list;
   resetEvents: name list;
   commands: (name * code) list;
   states: (name * State) list;}
  static member empty : Machine

Full name: Script.Machine


 State Machine record type
Machine.events: (name * code) list
type name = string

Full name: Script.name


 Name type abbreviation
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
Machine.resetEvents: name list
Machine.commands: (name * code) list
Machine.states: (name * State) list
type State =
  {actions: name list;
   transitions: (name * name) list;}
  static member empty : State

Full name: Script.State
static member Machine.empty : Machine

Full name: Script.Machine.empty
State.actions: name list
State.transitions: (name * name) list
static member State.empty : State

Full name: Script.State.empty
val whitespace : char []

Full name: Script.whitespace
val parseError : s:string -> 'a

Full name: Script.parseError
val s : string
val invalidOp : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.invalidOp
val parse : machine:Machine -> _arg1:string list -> Machine

Full name: Script.parse


 Returns new machine with values parsed from specified text
val machine : Machine
val xs : string list
val events : machine:Machine -> _arg2:string list -> Machine

Full name: Script.events


 Parses event declarations until end token is reached
val resetEvents : machine:Machine -> _arg3:string list -> Machine

Full name: Script.resetEvents


 Parses reset event declarations until end token is reached
val commands : machine:Machine -> _arg4:string list -> Machine

Full name: Script.commands


 Parses command declarations until end token is reached
Multiple items
val name : string

--------------------
type name = string

Full name: Script.name


 Name type abbreviation
val state' : State
val parseState : state:State -> _arg5:string list -> State * string list

Full name: Script.parseState


 Parses state declaration until end token is reached
property State.empty: State
val machine' : Machine
val x : string
Multiple items
val code : string

--------------------
type code = string

Full name: Script.code


 Code type abbreviation
val event : string * string
val command : string * string
val state : State
val actions' : name list
val actions : xs:string list -> name list * string list

Full name: Script.actions


 Parses action names in curly braces
val event : string
val action : string
val transition : string * string
val scope : (string list -> string list -> string * string list)


 Returns text inside curly braces scope
val acc : string list
module String

from Microsoft.FSharp.Core
val concat : sep:string -> strings:seq<string> -> string

Full name: Microsoft.FSharp.Core.String.concat
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val rev : list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.rev
System.String.Split([<System.ParamArray>] separator: char []) : string []
System.String.Split(separator: string [], options: System.StringSplitOptions) : string []
System.String.Split(separator: char [], options: System.StringSplitOptions) : string []
System.String.Split(separator: char [], count: int) : string []
System.String.Split(separator: string [], count: int, options: System.StringSplitOptions) : string []
System.String.Split(separator: char [], count: int, options: System.StringSplitOptions) : string []
module Array

from Microsoft.FSharp.Collections
val toList : array:'T [] -> 'T list

Full name: Microsoft.FSharp.Collections.Array.toList
val text : string

Full name: Script.text


 DSL specification
val machine : Machine

Full name: Script.machine


 Machine built from DSL text
namespace System
type StringSplitOptions =
  | None = 0
  | RemoveEmptyEntries = 1

Full name: System.StringSplitOptions
field System.StringSplitOptions.RemoveEmptyEntries = 1
property Machine.empty: Machine

More information

Link:http://fssnip.net/5h
Posted:12 years ago
Author:Phillip Trelford
Tags: dsl