+: State
                           #: Transition
                          
                           +--------------------------+
                           |            On            |
                           +--------------------------+
                                 ʌ             |
                                 |             v
                           #-----------#  #-----------#
                           | Off -> On |  | On -> Off |
                           #-----------#  #-----------#
                                 ʌ             |
                                 |             v
                           +--------------------------+
                           |            Off           |
                           +--------------------------+

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
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe                  #-}

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

module FSM.Light
  ( Off
  , On
  , Transition
  , off
  , on
  , switch
  )
where

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

data On
data Off

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

instance State On  where
instance State Off where

instance Transition On  Off where
instance Transition Off On  where

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

off     :: Off
on      :: On
switch  :: Transition a b => a -> b

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

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

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

{-# LANGUAGE Safe #-}

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

module Main (main) where

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

import           FSM.Light
  ( Off
  , On
  , off
  , switch
  )

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

blinking :: Either Off On -> Either Off On
blinking (Left  x) = Right $ switch x
blinking (Right x) = Left  $ switch x

{- We can't implement `blinking` incorrectly:

> blinking (Left x) = Left $ switch x

• No instance for (FSM.Light.Transition Off Off)
    arising from a use of ‘switch’
-}

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

main :: IO ()
main =
  do
    putStr "> Type the amount of times to turn on/off the ligth switch: "
    times <- getLine
    putStrLn . (++ " We turn on/off " ++ times ++ " time(s)") $ oi $ read times
      where
        si n = foldl (\a _ -> blinking a) (Left off) ([ 1 .. n ] :: [ Integer ])
        oi n =
          case si n of
            Left  _ -> "> OFF |"
            Right _ -> "> ON  |"

user@personal:~/../fsm$ ./Main.hs
> Type the amount of times to turn on/off the ligth switch: 0
> OFF | We turn on/off 0 time(s)
user@personal:~/../fsm$ ./Main.hs
> Type the amount of times to turn on/off the ligth switch: 10
> OFF | We turn on/off 10 time(s)
user@personal:~/../fsm$ ./Main.hs
> Type the amount of times to turn on/off the ligth switch: 11
> ON  | We turn on/off 11 time(s)
user@personal:~/../fsm$