--===========================--
--                           --
--   Telecom-application     --
--                           --
--===========================--
module POTS where

type Digit = Int
type Addr  = Int

data ToneType = Dial
              | Ring
              | Busy
              | Fault
              | None
              deriving Eq

data NumResponse = Invalid
                 | MoreDigits
                 | Valid PotsB Addr

struct TeleOS =
    start_ring  :: Addr -> Action
    stop_ring   :: Addr -> Action
    connect'    :: Addr -> Addr -> Action
    disconnect  :: Addr -> Addr -> Action
    start_tone  :: Addr -> ToneType -> Action
    stop_tone   :: Addr -> Action
    analyse     :: [Digit] -> NumResponse

struct PotsHW =
    off_hook    :: Action
    on_hook     :: Action
    digit       :: Digit -> Action

struct Pots =
    cleared     :: Action

struct PotsA < Pots =
    answered    :: Action

struct PotsB < Pots =
    seize       :: PotsA -> Request Bool

data PotsState = Idle
               | GetNumber   [Digit]
               | Ringing     PotsB Addr Time
               | Incoming    PotsA
               | Speech      Pots (Maybe Addr)
               | WaitOnHook  ToneType

newtype Time = Sec Int deriving Eq

struct Timer =
    set :: Time -> (Time -> Action) -> Request Time


pots myaddr tele_os timer =
    template
        state  := Idle
    in let
    
        off_hook = action
            case state of
                Idle ->
                    tele_os.start_tone myaddr Dial
                    state := GetNumber []
                Incoming p ->
                    tele_os.stop_ring myaddr
                    p.answered
                    state := Speech p Nothing
                _ -> done

        on_hook = action
            case state of
                GetNumber [] ->
                    tele_os.stop_tone myaddr
                Ringing p adr time ->
                    p.cleared
                    tele_os.stop_tone myaddr
                Speech p Nothing ->
                    p.cleared
                Speech p (Just addr) ->
                    p.cleared
                    tele_os.disconnect myaddr addr
                WaitOnHook typ | typ /= None ->
                    tele_os.stop_tone myaddr
                _ -> done
            state := Idle

        digit d = action
            case state of
                GetNumber nr ->
                    if null nr then
                        tele_os.stop_tone myaddr
                    let nr' = nr ++ [d]
                    case tele_os.analyse nr' of
                        Invalid ->
                            tele_os.start_tone myaddr Fault
                            state := WaitOnHook Fault
                        Valid p adr ->
                            ready <- do p.seize (struct ..PotsA)
                                     handle 
                                        Deadlock -> return False
                            if ready then
                                tele_os.start_tone myaddr Ring
                                tag <- timer.set (Sec 90) timeout
                                state := Ringing p adr tag
                             else
                                tele_os.start_tone myaddr Busy
                                state := WaitOnHook Busy
                        MoreDigits ->
                            state := GetNumber nr'
                _ -> done

        answered = action
            case state of
                Ringing p adr _ ->
                    tele_os.stop_tone myaddr
                    tele_os.connect' myaddr adr
                    state := Speech p (Just adr)
                _ -> done

        timeout tag = action
            case state of
                Ringing p adr tag' | tag == tag' ->
                    p.cleared
                    tele_os.stop_tone myaddr
                    tele_os.start_tone myaddr Fault
                    state := WaitOnHook Fault
                _ -> done

        cleared = action
            case state of
                Incoming p ->
                    tele_os.stop_ring myaddr
                    state := Idle
                Speech p Nothing ->
                    state := WaitOnHook None
                Speech p (Just adr) ->
                    tele_os.disconnect myaddr adr
                    state := WaitOnHook None
                _ -> done

        seize p = request
            case state of
                Idle ->
                    tele_os.start_ring myaddr
                    state := Incoming p
                    return True
                _ ->
                    return False

    in (struct ..PotsHW, struct ..PotsB)


--===============================--
--                               --
--   Alternative formulation     --
--                               --
--===============================--

struct S =
    off_hook'   :: O S ()
    on_hook'    :: O S ()
    digit'      :: Digit -> O S ()
    answered'   :: O S ()
    timeout'    :: Time -> O S ()
    cleared'    :: O S ()
    seize'      :: PotsA -> O S Bool

pots2 myaddr tele_os timer =
   template
      state := 

         let off_hook'   = done
             on_hook'    = done
             digit' _    = done
             answered'   = done
             timeout' _  = done
             cleared'    = done
             seize' _    = return False

             idle = struct

                 off_hook' = do
                     tele_os.start_tone myaddr Dial
                     state := getNumber []

                 seize' p = do
                     tele_os.start_ring myaddr
                     state := incoming p
                     return True

                 ..S

             getNumber nr = struct

                 on_hook' = do
                     if null nr then
                         tele_os.stop_tone myaddr
                     state := idle

                 digit' d = do
                     if null nr then
                         tele_os.stop_tone myaddr
                     let nr' = nr ++ [d]
                     case tele_os.analyse nr' of
                         Invalid ->
                             tele_os.start_tone myaddr Fault
                             state := waitOnHook Fault
                         Valid p_b adr ->
                             let me = struct
                                          cleared = action
                                              state.cleared'
                                          answered = action
                                              state.answered'
                             ready <- do p_b.seize me
                                      handle Deadlock -> return False
                             if ready then
                                 tele_os.start_tone myaddr Ring
                                 tag <- timer.set (Sec 90)
                                              (\tag -> action
                                                  state.timeout' tag)
                                 state := ringing p_b adr tag
                              else
                                 tele_os.start_tone myaddr Busy
                                 state := waitOnHook Busy
                         MoreDigits ->
                             state := getNumber nr'

                 ..S

             ringing p adr tag = struct

                 on_hook' = do
                     p.cleared
                     tele_os.stop_tone myaddr
                     state := idle

                 answered' = do
                     tele_os.stop_tone myaddr
                     tele_os.connect' myaddr adr
                     state := speech p (Just adr)

                 timeout' t
                     | t == tag = do
                         p.cleared
                         tele_os.stop_tone myaddr
                         tele_os.start_tone myaddr Fault
                         state := waitOnHook Fault
                     | otherwise =
                         done

                 ..S

             incoming p = struct

                 off_hook' = do
                     tele_os.stop_ring myaddr
                     p.answered
                     state := speech p Nothing

                 on_hook' = do
                     state := idle

                 cleared' = do
                     tele_os.stop_ring myaddr
                     state := idle
                     
                 ..S

             speech p Nothing = struct

                 on_hook' = do
                     p.cleared
                     state := idle

                 cleared' = do
                     state := waitOnHook None

                 ..S

             speech p (Just adr) = struct

                 on_hook' = do
                     p.cleared
                     tele_os.disconnect myaddr adr
                     state := idle

                 cleared' = do
                     tele_os.disconnect myaddr adr
                     state := waitOnHook None

                 ..S

             waitOnHook typ = struct
             
                 on_hook' = do
                     if typ /= None then
                         tele_os.stop_tone myaddr
                     state := idle

                 ..S

         in idle

   in ( struct
           off_hook    = action state.off_hook'
           on_hook     = action state.on_hook'
           digit d     = action state.digit' d ,
        struct
           cleared     = action state.cleared'
           seize p     = request state.seize' p )