Design and Interpretation

Main.hs

-- The actual IO implementation of the program

withFreenode :: (Handle -> IO a) -> IO a
withFreenode f =
  runTCPClient "irc.freenode.net" "6667" $ \sock -> do
    irc <- socketToHandle sock ReadWriteMode
    hSetBuffering irc LineBuffering
    f irc <* hClose irc


main :: IO ()
main = withFreenode $ \irc -> do
  runApp (Stuff irc) $ do
    (recv, send) <- connectAndGetStreams "helloworld1234" "Sandy" "#irccat"
    void
      . liftIO
      . forkIO
      . runApp (Stuff irc)
      . S.print
      $ recv
    send $ S.fromHandle stdin

Program.hs

-- The abstract logic of the program

connectAndGetStreams
    :: ( MonadIRC m
       , MonadFinal m
       )
    => Nick
    -> String
    -> Channel
    -> m ( Stream (Of RecvMsg) m ()
         , Stream (Of String) m b -> m b
         )
    -- ^ A pair of streams of (incoming, outgoing) messages
connectAndGetStreams nick name chan = do
  traverse_ sendIRC $ loginFlow nick name [chan]
  pure
    ( recvMessages
    , flip finally (sendIRC $ QUIT "leaving")
        . S.mapM_ sendIRC
        . S.map (PRIVMSG [RecipientChannel chan])
    )

TestHarness.hs

-- A test harness for running the abstract program

type MockedM = WriterT [IRCCommand] (State [RecvCommand])

data Dicts =
  Dicts
    (Improvised (MonadIRC MockedM))
    (Improvised (MonadFinal MockedM))
makeImprovCollection ''Dicts

mockedIRC
    :: Improvised (MonadIRC MockedM)
mockedIRC = MonadIRC
  { _sendIRC = tell . pure
  , _recvNewMessage = do
      res <- gets listToMaybe
      modify $ drop 1
      pure res
  }

unsafeFinal :: Improvised (MonadFinal MockedM)
unsafeFinal = MonadFinal
  { _finally = (<*)
  }