Created
June 29, 2017 01:40
-
-
Save benjamin-hodgson/caf10fbb241f3f79c20886188c3cfb83 to your computer and use it in GitHub Desktop.
Modelling stateful request/response processes using dual functors
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DeriveFunctor #-} | |
{-# LANGUAGE FunctionalDependencies #-} | |
{-# LANGUAGE UndecidableInstances #-} | |
import Control.Monad (ap) | |
import Control.Monad.Free | |
import Control.Comonad | |
import Control.Comonad.Cofree | |
import Data.List | |
class (Functor f, Functor g) => Zap f g | f -> g, g -> f where | |
zap :: (a -> b -> c) -> f a -> g b -> c | |
instance Zap f g => Zap (Free f) (Cofree g) where | |
zap f (Pure x) (y :< ys) = f x y | |
zap f (Free g) (y :< ys) = zap (zap f) g ys | |
type Msg = String | |
type CardNumber = String | |
type Amt = Int | |
data ClientF r = Chat String r | |
| Pay CardNumber Amt (Bool -> r) | |
deriving Functor | |
data ServerF r = Server { | |
rcvChat :: String -> r, | |
rcvPay :: CardNumber -> Amt -> (Bool, r) | |
} deriving Functor | |
instance Zap ClientF ServerF where | |
zap f (Chat msg x) server = f x (server `rcvChat` msg) | |
zap f (Pay card amt k) server = | |
let (accepted, y) = rcvPay server card amt | |
in f (k accepted) y | |
type Client = Free ClientF | |
type Server = Cofree ServerF | |
myServer :: Server () | |
myServer = awaitPoliteMsg | |
where awaitPoliteMsg = () :< Server { rcvChat = rcvChat, rcvPay = \card amt -> (False, awaitPoliteMsg) } | |
rcvChat msg | |
| "please" `isInfixOf` msg = () :< Server { rcvChat = rcvChat, rcvPay = \card amt -> (True, awaitPoliteMsg) } | |
| otherwise = awaitPoliteMsg | |
chat :: String -> Client () | |
chat x = liftF $ Chat x () | |
pay :: CardNumber -> Amt -> Client Bool | |
pay card amt = liftF $ Pay card amt id | |
myClient :: Client String | |
myClient = do | |
chat "I would like to buy a Haskell please" | |
accepted <- pay "1234-5678" 500 | |
if accepted | |
then return "yay!" | |
else return "boo!" | |
run = zap const myClient myServer | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment