-- | Another complete example for the library
module Main where
import Data.Dynamic
import Control.Eff
import Control.Eff.Concurrent
import Control.Eff.Concurrent.Protocol.Server
import Control.Monad
import Data.Foldable
import Control.Lens
import Control.Concurrent
import Control.DeepSeq
import qualified Data.Text as T
import Data.Type.Pretty
main :: IO ()
main = defaultMain (void counterExample)
-- * First API
data Counter deriving Typeable
type instance ToPretty Counter = PutStr "counter"
data instance Pdu Counter x where
Inc :: Pdu Counter 'Asynchronous
Cnt :: Pdu Counter ('Synchronous Integer)
deriving Typeable
instance NFData (Pdu Counter x) where
rnf Inc = ()
rnf Cnt = ()
counterExample
:: (Typeable q, LogsTo IO q, Lifted IO q)
=> Eff (InterruptableProcess q) ()
counterExample = do
c <- spawnCounter
let cp = _fromEndpoint c
lift (threadDelay 500000)
o <- logCounterObservations
lift (threadDelay 500000)
registerObserver o c
lift (threadDelay 500000)
cast c Inc
lift (threadDelay 500000)
sendMessage cp ("test 123" :: String)
cast c Inc
lift (threadDelay 500000)
cast c Inc
sendMessage cp (12312312 :: Int)
lift (threadDelay 500000)
cast c Inc
lift (threadDelay 500000)
cast c Inc
lift (threadDelay 500000)
cast c Inc
lift (threadDelay 500000)
r <- call c Cnt
lift (threadDelay 500000)
lift (putStrLn ("r: " ++ show r))
lift (threadDelay 500000)
lift (threadDelay 500000)
data SupiDupi deriving Typeable
type instance ToPretty SupiDupi = PutStr "supi dupi"
data instance Pdu SupiDupi r where
Whoopediedoo :: Bool -> Pdu SupiDupi ('Synchronous (Maybe ()))
deriving Typeable
instance Show (Pdu SupiDupi r) where
show (Whoopediedoo True) = "woopediedooo"
show (Whoopediedoo False) = "no woopy doopy"
instance NFData (Pdu SupiDupi r) where
rnf (Whoopediedoo b) = rnf b
newtype CounterChanged = CounterChanged Integer
deriving (Show, Typeable, NFData)
type instance ToPretty CounterChanged = PutStr "counter changed"
type SupiCounter = (Counter, ObserverRegistry CounterChanged, SupiDupi)
type instance ToPretty (Counter, ObserverRegistry CounterChanged, SupiDupi) = PutStr "supi-counter"
instance (LogIo q) => Server SupiCounter (InterruptableProcess q) where
type instance Model SupiCounter = (Integer, Observers CounterChanged, Maybe (RequestOrigin SupiCounter (Maybe ())))
data instance StartArgument SupiCounter (InterruptableProcess q) = MkEmptySupiCounter
setup _ = return ((0, emptyObservers, Nothing), ())
update _ = \case
OnRequest req ->
case req of
Call orig callReq ->
case callReq of
ToPdu1 Cnt ->
sendReply orig =<< useModel @SupiCounter _1
ToPdu2 _ -> error "unreachable"
ToPdu3 (Whoopediedoo c) ->
modifyModel @SupiCounter (_3 .~ if c then Just orig else Nothing)
Cast castReq ->
case castReq of
ToPdu1 Inc -> do
val' <- view _1 <$> modifyAndGetModel @SupiCounter (_1 %~ (+ 1))
zoomModel @SupiCounter _2 (observed (CounterChanged val'))
when (val' > 5) $
getAndModifyModel @SupiCounter (_3 .~ Nothing)
>>= traverse_ (flip sendReply (Just ())) . view _3
ToPdu2 x ->
zoomModel @SupiCounter _2 (handleObserverRegistration x)
ToPdu3 _ -> error "unreachable"
other -> logWarning (T.pack (show other))
spawnCounter :: (LogsTo IO q, Lifted IO q) => Eff (InterruptableProcess q) ( Endpoint SupiCounter )
spawnCounter = start MkEmptySupiCounter
deriving instance Show (Pdu Counter x)
logCounterObservations
:: (LogsTo IO q, Lifted IO q, Typeable q)
=> Eff (InterruptableProcess q) (Observer CounterChanged)
logCounterObservations = do
svr <- start
$ genServer @(Observer CounterChanged)
(\_me -> pure (emptyObservers, ()))
(\_me ->
\case
OnRequest (Cast r) ->
handleObservations (\msg -> logInfo' ("observed: " ++ show msg)) r
wtf -> logNotice (T.pack (show wtf))
)
"counter logger"
pure (toObserver svr)
type instance GenServerModel (Observer CounterChanged) = Observers CounterChanged
type instance GenServerSettings (Observer CounterChanged) = ()
type instance GenServerProtocol (Observer CounterChanged) = Observer CounterChanged