6 people like it.

Finite State Machine Compiler

Based on Uncle Bob's State Machine Compiler for Clean Code video series, parser implemented with FParsec, see https://github.com/unclebob/CC_SMC for Uncle Bob's Java implementation.

Abstract Syntax Tree

1: 
2: 
3: 
4: 
5: 
6: 
type Name = string
type Event = Name
type State = Name
type Action = Name
type Transition = { OldState:State; Event:Event; NewState:State; Actions:Action list }
type Header = Header of Name * Name

Parser

 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: 
open FParsec

let pname = many1SatisfyL isLetter "name"

let pheader = pname .>> pstring ":" .>> spaces1 .>>. pname .>> spaces |>> Header

let pactions = 
   let paction = pname
   paction |>> fun action -> [action]
   <|> between (pstring "{") (pstring "}") (many (paction .>> spaces))

let psubtransition =
   pipe3 (pname .>> spaces1) (pname .>> spaces1) pactions 
         (fun event newState actions -> event,newState,actions)

let ptransition1 =
   pname .>> spaces1 .>>. psubtransition
   |>> fun (oldState,(event,newState,actions)) -> 
      [{OldState=oldState;Event=event;NewState=newState;Actions=actions}]

let ptransitionGroup =
   let psub = spaces >>. psubtransition .>> spaces
   pname .>> spaces .>>. (between (pstring "{") (pstring "}") (many1 psub))
   |>> fun (oldState,subs) -> 
      [for (event,newState,actions) in subs -> 
         {OldState=oldState;Event=event;NewState=newState;Actions=actions}]

let ptransitions =
   let ptrans = attempt ptransition1 <|> ptransitionGroup
   between (pstring "{") (pstring "}") (many (spaces >>. ptrans .>> spaces))
   |>> fun trans -> List.collect id trans

let pfsm = spaces >>. many pheader .>>. ptransitions .>> spaces

let parse code =
   match run pfsm code with
   | Success(result,_,_) -> result
   | Failure(msg,_,_) -> failwith msg

Compiler

 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: 
let compile (headers,transitions) =
   let header name = 
      headers |> List.pick (function Header(key,value) when key = name -> Some value | _ -> None)
   let states = 
      transitions |> List.collect (fun trans -> [trans.OldState;trans.NewState]) |> Seq.distinct      
   let events =
      transitions |> List.map (fun trans -> trans.Event) |> Seq.distinct

   "package thePackage;\n" +
   (sprintf "public abstract class %s implements %s {\n" (header "FSM") (header "Actions")) +
   "\tpublic abstract void unhandledTransition(String state, String event);\n" +
   (sprintf "\tprivate enum State {%s}\n" (String.concat "," states)) +
   (sprintf "\tprivate enum Event {%s}\n" (String.concat "," events)) +
   (sprintf "\tprivate State state = State.%s;\n" (header "Initial")) +
   "\tprivate void setState(State s) {state = s;}\n" +
   "\tprivate void handleEvent(Event event) {\n" +
   "\t\tswitch(state) {\n" +
   (String.concat ""
      [for (oldState,ts) in transitions |> Seq.groupBy (fun t -> t.OldState) ->
         (sprintf "\t\t\tcase %s:\n" oldState) +
         "\t\t\t\tswitch(event) {\n" +
         (String.concat ""
            [for t in ts ->
               (sprintf "\t\t\t\t\tcase %s:\n" t.Event) +
               (sprintf "\t\t\t\t\t\tsetState(State.%s);\n" t.NewState)+
               (String.concat ""
                  [for a in t.Actions -> sprintf "\t\t\t\t\t\t%s();\n" a]
               ) +
               "\t\t\t\t\t\tbreak;\n"
            ]         
         ) +
         "\t\t\t\t\tdefault: unhandledTransition(state.name(), event.name()); break;\n" +
         "\t\t\t\t}\n" +
         "\t\t\t\tbreak;\n"
      ] 
   )+   
   "\t\t}\n" +
   "\t}\n" +   
   "}\n"

Example

 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: 
let example = "Actions: Turnstile
          FSM: OneCoinTurnstile
          Initial: Locked
          {
            Locked Coin Unlocked {alarmOff unlock}
            Locked Pass Locked  alarmOn
            Unlocked Coin Unlocked thankyou
            Unlocked Pass Locked lock
          }
"
example |> parse |> compile
(*
val it : string =
  "package thePackage;
public abstract class OneCoinTurnstile implements Turnstile {
	public abstract void unhandledTransition(String state, String event);
	private enum State {Locked,Unlocked}
	private enum Event {Coin,Pass}
	private State state = State.Locked;
	private void setState(State s) {state = s;}
	private void handleEvent(Event event) {
		switch(state) {
			case Locked:
				switch(event) {
					case Coin:
						setState(State.Unlocked);
						alarmOff();
						unlock();
						break;
					case Pass:
						setState(State.Locked);
						alarmOn();
						break;
					default: unhandledTransition(state.name(), event.name()); break;
				}
				break;
			case Unlocked:
				switch(event) {
					case Coin:
						setState(State.Unlocked);
						thankyou();
						break;
					case Pass:
						setState(State.Locked);
						lock();
						break;
					default: unhandledTransition(state.name(), event.name()); break;
				}
				break;
		}
	}
}
"
*)
Multiple items
val string : value:'T -> string

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

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

Full name: Microsoft.FSharp.Core.string
Multiple items
module Event

from Microsoft.FSharp.Control

--------------------
type Event = Name

Full name: Script.Event

--------------------
type Event<'T> =
  new : unit -> Event<'T>
  member Trigger : arg:'T -> unit
  member Publish : IEvent<'T>

Full name: Microsoft.FSharp.Control.Event<_>

--------------------
type Event<'Delegate,'Args (requires delegate and 'Delegate :> Delegate)> =
  new : unit -> Event<'Delegate,'Args>
  member Trigger : sender:obj * args:'Args -> unit
  member Publish : IEvent<'Delegate,'Args>

Full name: Microsoft.FSharp.Control.Event<_,_>

--------------------
new : unit -> Event<'T>

--------------------
new : unit -> Event<'Delegate,'Args>
type Name = string

Full name: Script.Name
type State = Name

Full name: Script.State
type Action = Name

Full name: Script.Action
type Transition =
  {OldState: State;
   Event: Event;
   NewState: State;
   Actions: Action list;}

Full name: Script.Transition
Transition.OldState: State
Multiple items
Transition.Event: Event

--------------------
module Event

from Microsoft.FSharp.Control

--------------------
type Event = Name

Full name: Script.Event

--------------------
type Event<'T> =
  new : unit -> Event<'T>
  member Trigger : arg:'T -> unit
  member Publish : IEvent<'T>

Full name: Microsoft.FSharp.Control.Event<_>

--------------------
type Event<'Delegate,'Args (requires delegate and 'Delegate :> Delegate)> =
  new : unit -> Event<'Delegate,'Args>
  member Trigger : sender:obj * args:'Args -> unit
  member Publish : IEvent<'Delegate,'Args>

Full name: Microsoft.FSharp.Control.Event<_,_>

--------------------
new : unit -> Event<'T>

--------------------
new : unit -> Event<'Delegate,'Args>
Transition.NewState: State
Transition.Actions: Action list
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
Multiple items
union case Header.Header: Name * Name -> Header

--------------------
type Header = | Header of Name * Name

Full name: Script.Header
namespace FParsec
val pname : Parser<string,unit>

Full name: Script.pname
val many1SatisfyL : (char -> bool) -> string -> Parser<string,'u>

Full name: FParsec.CharParsers.many1SatisfyL
val isLetter : char -> bool

Full name: FParsec.CharParsers.isLetter
val pheader : Parser<Header,unit>

Full name: Script.pheader
val pstring : string -> Parser<string,'u>

Full name: FParsec.CharParsers.pstring
val spaces1 : Parser<unit,'u>

Full name: FParsec.CharParsers.spaces1
val spaces : Parser<unit,'u>

Full name: FParsec.CharParsers.spaces
val pactions : Parser<string list,unit>

Full name: Script.pactions
val paction : Parser<string,unit>
val action : string
val between : Parser<'a,'u> -> Parser<'b,'u> -> Parser<'c,'u> -> Parser<'c,'u>

Full name: FParsec.Primitives.between
val many : Parser<'a,'u> -> Parser<'a list,'u>

Full name: FParsec.Primitives.many
val psubtransition : Parser<(string * string * string list),unit>

Full name: Script.psubtransition
val pipe3 : Parser<'a,'u> -> Parser<'b,'u> -> Parser<'c,'u> -> ('a -> 'b -> 'c -> 'd) -> Parser<'d,'u>

Full name: FParsec.Primitives.pipe3
val event : string
val newState : string
val actions : string list
val ptransition1 : Parser<Transition list,unit>

Full name: Script.ptransition1
val oldState : string
val ptransitionGroup : Parser<Transition list,unit>

Full name: Script.ptransitionGroup
val psub : Parser<(string * string * string list),unit>
val many1 : Parser<'a,'u> -> Parser<'a list,'u>

Full name: FParsec.Primitives.many1
val subs : (string * string * string list) list
val ptransitions : Parser<Transition list,unit>

Full name: Script.ptransitions
val ptrans : Parser<Transition list,unit>
val attempt : Parser<'a,'u> -> Parser<'a,'u>

Full name: FParsec.Primitives.attempt
val trans : Transition list list
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 collect : mapping:('T -> 'U list) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.collect
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val pfsm : Parser<(Header list * Transition list),unit>

Full name: Script.pfsm
val parse : code:string -> Header list * Transition list

Full name: Script.parse
val code : string
val run : Parser<'Result,unit> -> string -> ParserResult<'Result,unit>

Full name: FParsec.CharParsers.run
union case ParserResult.Success: 'Result * 'UserState * Position -> ParserResult<'Result,'UserState>
val result : Header list * Transition list
union case ParserResult.Failure: string * ParserError * 'UserState -> ParserResult<'Result,'UserState>
val msg : string
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val compile : headers:Header list * transitions:Transition list -> string

Full name: Script.compile
val headers : Header list
val transitions : Transition list
val header : (Name -> Name)
val name : Name
val pick : chooser:('T -> 'U option) -> list:'T list -> 'U

Full name: Microsoft.FSharp.Collections.List.pick
val key : Name
val value : Name
union case Option.Some: Value: 'T -> Option<'T>
union case Option.None: Option<'T>
val states : seq<State>
val trans : Transition
module Seq

from Microsoft.FSharp.Collections
val distinct : source:seq<'T> -> seq<'T> (requires equality)

Full name: Microsoft.FSharp.Collections.Seq.distinct
val events : seq<Event>
val map : mapping:('T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.map
Transition.Event: Event
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
module String

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

Full name: Microsoft.FSharp.Core.String.concat
val oldState : State
val ts : seq<Transition>
val groupBy : projection:('T -> 'Key) -> source:seq<'T> -> seq<'Key * seq<'T>> (requires equality)

Full name: Microsoft.FSharp.Collections.Seq.groupBy
val t : Transition
val a : Action
val example : string

Full name: Script.example

More information

Link:http://fssnip.net/oO
Posted:2 years ago
Author:Phillip Trelford
Tags: ast , parser , fparsec , compiler