{-# LANGUAGE ExistentialQuantification #-}
-- MultiParamTypeClasses FunctionalDependencies
module OS where

-- TODO try avoiding double-matching for metamessages and the need for
-- broadcast by introducing a facility for supporting event-pattern
-- subtyping

import Control.Arrow ((>>>))
import Data.Maybe
import Data.List
import Control.Concurrent.Chan

data VM m mm = VM { suspensions :: [Suspension m mm],
                    messages :: [m],
                    metaMessages :: [mm],
                    runnables :: [Callback m mm ()] }
type Callback m mm state = (state -> KernelModeTransition m mm)
data Suspension m mm = forall state. Suspension
                                        state
                                        (Maybe (Callback m mm state))
                                        [Handler m mm state]
                                        [MetaHandler m mm state]
data KernelModeTransition m mm = KernelModeTransition (Suspension m mm)
                                                      [m]
                                                      [mm]
                                                      [Callback m mm ()]
type Handler m mm state = (m -> Maybe (Callback m mm state))
type MetaHandler m mm state = (mm -> Maybe (Callback m mm state))

newVM boot = VM { suspensions = [],
                  messages = [],
                  metaMessages = [],
                  runnables = [boot] }

runVM :: VM m mm -> KernelModeTransition mm mm1
runVM = rebuildSuspensions enqueuePoller >>> runRunnables >>> dispatchMessages >>> \ vm ->
        let mms = reverse $ metaMessages vm
            mmhs = concatMap extractDown $ suspensions vm
            pollerK = if shouldPoll vm then Just runVM else Nothing
        in
          KernelModeTransition (Suspension (vm { metaMessages = [] }) pollerK mmhs []) mms [] []

rebuildSuspensions :: (VM m mm -> Suspension m mm -> VM m mm) -> (VM m mm) -> (VM m mm)
rebuildSuspensions f vm = foldl f (vm { suspensions = [] }) (suspensions vm)

enqueuePoller :: VM m mm -> Suspension m mm -> VM m mm
enqueuePoller vm susp@(Suspension state k _ _) =
    if isPolling susp
    then vm { runnables = (\ () -> (fromJust k) state) : runnables vm }
    else vm { suspensions = susp : suspensions vm }

runRunnables :: VM m mm -> VM m mm
runRunnables vm = foldl runRunnable (vm { runnables = [] }) (reverse (runnables vm))
runRunnable vm r = performTransition (r ()) vm

dispatchMessages :: VM m mm -> VM m mm
dispatchMessages vm = foldr dispatchMessage (vm { messages = [] }) (messages vm)

dispatchMessage m = rebuildSuspensions matchSuspension
    where matchSuspension vm susp@(Suspension state _ mhs _) =
              searchHandlers vm susp state m mhs

searchHandlers vm susp state m [] = vm { suspensions = susp : suspensions vm }
searchHandlers vm susp state m (mh:mhs) =
    case mh m of
      Just h -> performTransition (h state) vm
      Nothing -> searchHandlers vm susp state m mhs

extractDown (Suspension _ _ _ mmhs) = map matchMetaMessage mmhs
    where matchMetaMessage mmh mm =
              case mmh mm of
                Nothing -> Nothing
                Just _ -> Just (runMetaHandler mm)

isPolling (Suspension _ pollerK _ _) = isNothing pollerK
isBlocked = not . isPolling

shouldPoll vm@(VM { messages = [], runnables = []}) = not $ all isBlocked (suspensions vm)
shouldPoll _ = True

runMetaHandler :: mm -> (VM m mm) -> (KernelModeTransition mm mm1)
runMetaHandler mm = runVM . rebuildSuspensions dispatchMetaMessage
    where dispatchMetaMessage vm susp@(Suspension state _ _ mmhs) =
              searchHandlers vm susp state mm mmhs

performTransition :: KernelModeTransition m mm -> VM m mm -> VM m mm
performTransition (KernelModeTransition susp ms mms cbs) vm =
    vm { suspensions = susp : suspensions vm,
         messages = reverse ms ++ (messages vm),
         metaMessages = reverse mms ++ (metaMessages vm),
         runnables = reverse cbs ++ (runnables vm) }