1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe                  #-}

--------------------------------------------------------------------------------

module FSM.FiniteStateMachine
  ( State
  , Transition
  , switch
  )
where

--------------------------------------------------------------------------------

class  State a                             where
class (State a, State b) => Transition a b where

--------------------------------------------------------------------------------

switch :: Transition a b => a -> b

--------------------------------------------------------------------------------

switch = undefined

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
#!/usr/bin/env stack
{- stack
   --resolver lts-12.0
   --install-ghc
   script
   --ghc-options -Werror
   --ghc-options -Wall
   --
-}

--------------------------------------------------------------------------------

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe                  #-}

--------------------------------------------------------------------------------

module Main (main) where

--------------------------------------------------------------------------------

import           FSM.FiniteStateMachine
  ( State
  , Transition
  , switch
  )

--------------------------------------------------------------------------------

-- We define states and transitions into the type system

data Red
data Yellow
data Green

instance Show Red    where show _ = "Red"
instance Show Yellow where show _ = "Yellow"
instance Show Green  where show _ = "Green"

instance State Red
instance State Yellow
instance State Green

instance Transition Red    Green
instance Transition Green  Yellow
instance Transition Yellow Red

--------------------------------------------------------------------------------

-- We define our finite-state-machine (FSM)

data TrafficLight
  = Stop    Red
  | Caution Yellow
  | Go      Green
  deriving Show

--------------------------------------------------------------------------------

main :: IO ()
main =
  do
    putStrLn . ps $ show s0
    putStrLn . ps $ show s1
    putStrLn . ps $ show s2
    putStrLn . ps $ show s3
      where
        s0@(Stop    s0') = Stop    $ undefined
        s1@(Go      s1') = Go      $ switch s0'
        {- We can't implement code that goes from `Green` to `Red`:
           > si@(Stop si') = Stop $ switch s1'
           • No instance for (Transition Green Red)
               arising from a use of ‘switch’
        -}
        s2@(Caution s2') = Caution $ switch s1'
        s3               = Stop    $ switch s2'
        ps = ("The traffic light is: " ++)

user@personal:~/../fsm/lib$ ./Main.hs
The traffic light is: Stop Red
The traffic light is: Go Green
The traffic light is: Caution Yellow
The traffic light is: Stop Red