summaryrefslogtreecommitdiff
path: root/src/Service.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2020-02-04 23:28:46 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2020-02-04 23:28:46 +0100
commit8dc945aae35fffd8e64c524b71d7316297721daf (patch)
treed1a000e303f6a22fdcf522b2b4729a81ea0c2fcc /src/Service.hs
parent6f0bcff200598d085c89d167aa126d25fc5df3ed (diff)
Service: unify service and packet types
Also provide default unit definition for the service state.
Diffstat (limited to 'src/Service.hs')
-rw-r--r--src/Service.hs31
1 files changed, 16 insertions, 15 deletions
diff --git a/src/Service.hs b/src/Service.hs
index d2848b6..697934b 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -28,27 +28,28 @@ import Identity
import State
import Storage
-class (Typeable s, Storable (ServicePacket s)) => Service s where
+class (Typeable s, Storable s, Typeable (ServiceState s)) => Service s where
serviceID :: proxy s -> ServiceID
+ serviceHandler :: Stored s -> ServiceHandler s ()
- data ServiceState s :: *
- emptyServiceState :: ServiceState s
-
- data ServicePacket s :: *
- serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s ()
+ type ServiceState s :: *
+ type ServiceState s = ()
+ emptyServiceState :: proxy s -> ServiceState s
+ default emptyServiceState :: ServiceState s ~ () => proxy s -> ServiceState s
+ emptyServiceState _ = ()
data SomeService = forall s. Service s => SomeService (Proxy s)
-data SomeServiceState = forall s. Service s => SomeServiceState (ServiceState s)
+data SomeServiceState = forall s. Service s => SomeServiceState (Proxy s) (ServiceState s)
someServiceID :: SomeService -> ServiceID
someServiceID (SomeService s) = serviceID s
-fromServiceState :: Service s => SomeServiceState -> Maybe (ServiceState s)
-fromServiceState (SomeServiceState s) = cast s
+fromServiceState :: Service s => proxy s -> SomeServiceState -> Maybe (ServiceState s)
+fromServiceState _ (SomeServiceState _ s) = cast s
someServiceEmptyState :: SomeService -> SomeServiceState
-someServiceEmptyState (SomeService (Proxy :: Proxy s)) = SomeServiceState (emptyServiceState :: ServiceState s)
+someServiceEmptyState (SomeService p) = SomeServiceState p (emptyServiceState p)
newtype ServiceID = ServiceID UUID
deriving (Eq, Ord, StorableUUID)
@@ -61,7 +62,7 @@ data ServiceInput = ServiceInput
, svcPrintOp :: String -> IO ()
}
-data ServiceReply s = ServiceReply (Either (ServicePacket s) (Stored (ServicePacket s))) Bool
+data ServiceReply s = ServiceReply (Either s (Stored s)) Bool
data ServiceHandlerState s = ServiceHandlerState
{ svcValue :: ServiceState s
@@ -71,7 +72,7 @@ data ServiceHandlerState s = ServiceHandlerState
newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT String IO))) a)
deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError String, MonadIO)
-handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored (ServicePacket s) -> IO ([ServiceReply s], ServiceState s)
+handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored s -> IO ([ServiceReply s], ServiceState s)
handleServicePacket st input svc packet = do
herb <- loadLocalStateHead st
let erb = wrappedLoad $ headRef herb
@@ -102,11 +103,11 @@ svcSetLocal x = modify $ \st -> st { svcLocal = x }
svcPrint :: String -> ServiceHandler s ()
svcPrint str = liftIO . ($str) =<< asks svcPrintOp
-replyPacket :: Service s => ServicePacket s -> ServiceHandler s ()
+replyPacket :: Service s => s -> ServiceHandler s ()
replyPacket x = tell [ServiceReply (Left x) True]
-replyStored :: Service s => Stored (ServicePacket s) -> ServiceHandler s ()
+replyStored :: Service s => Stored s -> ServiceHandler s ()
replyStored x = tell [ServiceReply (Right x) True]
-replyStoredRef :: Service s => Stored (ServicePacket s) -> ServiceHandler s ()
+replyStoredRef :: Service s => Stored s -> ServiceHandler s ()
replyStoredRef x = tell [ServiceReply (Right x) False]