Skip to content

Instantly share code, notes, and snippets.

@benjamin-hodgson
Created June 29, 2017 01:40
Show Gist options
  • Save benjamin-hodgson/caf10fbb241f3f79c20886188c3cfb83 to your computer and use it in GitHub Desktop.
Save benjamin-hodgson/caf10fbb241f3f79c20886188c3cfb83 to your computer and use it in GitHub Desktop.
Modelling stateful request/response processes using dual functors
{-# 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