Basic FSM

FSM.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

module FSM
  ( FooEvent(..)
  , FooState(..)
  , Foo()
  , mkFoo
  , trFoo
  , getFooEvents
  , getFooState
  )
where

type FSM e s = e -> s -> s

data FooEvent = E1 | E2 | E3 deriving (Eq, Ord, Show)
data FooState = S1 | S2 | S3 | S4 deriving (Eq, Ord, Show)

data Foo = Foo
  { events :: [FooEvent]
  , state  :: FooState
  } deriving (Eq, Show)

mkFoo :: [FooEvent] -> Foo
mkFoo events = Foo events (foldr fooFSM S1 events)

trFoo :: Foo -> FooEvent -> Foo
trFoo Foo {..} event = Foo (event : events) (fooFSM event state)

getFooEvents :: Foo -> [FooEvent]
getFooEvents = events

getFooState :: Foo -> FooState
getFooState = state

fooFSM :: FSM FooEvent FooState
fooFSM E1 S1 = S2
fooFSM E2 S2 = S3
fooFSM E3 S3 = S4
fooFSM _  s  = s

FSMSpec.hs

module FSMSpec
  ( spec
  )
where

import Test.Hspec
import FSM

spec :: Spec
spec = do
  describe "Foo creation" $ do
    it "Foo created from empty events has state S1" $
      getFooState (mkFoo []) `shouldBe` S1

    it "Foo created from events [E1] has state S2" $
      getFooState (mkFoo [E1]) `shouldBe` S2

    it "Foo created from events [E2, E1] has state S3" $
      getFooState (mkFoo [E2,E1]) `shouldBe` S3

    it "Foo created from events [E2] has state S1" $
      getFooState (mkFoo [E2]) `shouldBe` S1

    it "Foo created from events [E1, E1] has state S2" $
      getFooState (mkFoo [E1, E1]) `shouldBe` S2

  describe "Foo transition" $ do
    it "Foo transitioned from S3 via E4 has state S4" $
      getFooState (trFoo (mkFoo [E2,E1]) E3) `shouldBe` S4

    it "Foo transitioned from S3 via E1 has state S3" $
      getFooState (trFoo (mkFoo [E2,E1]) E1) `shouldBe` S3