StockLique Monad Transformer

StockLiquorT.hs

{-
   Goal:

   - Recover from OverpricedDrinkErrors and continue charging for drinks
   - Simulate a NetworkError
   - Use finally to ensure the CreditCardAPIConnection is closed in the event
     of an error
-}
module StockLiquorT where

import qualified Control.Exception as Exc
import qualified Control.Monad.Trans as Trans
import qualified Data.Fixed as Fixed
import qualified Data.Map as Map
import qualified Data.Typeable as Typable

data Drink
  = VodkaTonic
  | RumAndCoke
  deriving (Show, Eq, Ord)

data Receipt =
  Receipt
    { receiptDrink :: Drink
    , receiptPrice :: Fixed.Centi
    } deriving Show

type Market = Map.Map Drink Fixed.Centi

newtype StockLiquorT m a =
  StockLiquorT
    { runStockLiquorT :: Market -> m (a, Market)
    }

instance Functor m => Functor (StockLiquorT m) where
  fmap f sl =
    StockLiquorT $ \market ->
      let
        mapResult (a, m) = (f a, m)
      in
        fmap mapResult $ runStockLiquorT sl market

instance Monad m => Applicative (StockLiquorT m) where
  pure =
    pureMarket

  slF <*> slA =
    linkMarket slF $ \f ->
    linkMarket slA $ \a ->
    pureMarket (f a)

instance Monad m => Monad (StockLiquorT m) where
  (>>=) = linkMarket

instance Trans.MonadTrans StockLiquorT where
  lift ma =
    StockLiquorT $ \market ->
      fmap (\a -> (a,market)) ma

linkMarket
  :: Monad m
  => StockLiquorT m a
  -> (a -> StockLiquorT m b)
  -> StockLiquorT m b
linkMarket marketToA aToB =
  StockLiquorT $ \market -> do
    (a, newMarket) <- runStockLiquorT marketToA market
    runStockLiquorT (aToB a) newMarket

pureMarket :: Applicative m => a -> StockLiquorT m a
pureMarket a =
  StockLiquorT $ \market -> pure (a, market)

getMarket :: Applicative m => StockLiquorT m Market
getMarket =
  StockLiquorT $ \market -> pure (market, market)

putMarket :: Applicative m => Market -> StockLiquorT m ()
putMarket newMarket =
  StockLiquorT $ \_ -> pure ((), newMarket)

marketDrinkPrice :: Drink -> Market -> Fixed.Centi
marketDrinkPrice drink market =
  Map.findWithDefault (defaultDrinkPrice drink) drink market

defaultDrinkPrice :: Drink -> Fixed.Centi
defaultDrinkPrice drink =
  case drink of
    VodkaTonic -> 16.80
    RumAndCoke ->  4.75

demandDrink :: Monad m => Drink -> StockLiquorT m Fixed.Centi
demandDrink drink = do
  market <- getMarket

  let
    thisPrice = marketDrinkPrice drink market
    nextPrice = thisPrice + 20.00
    newMarket = Map.insert drink nextPrice market

  putMarket newMarket
  pure thisPrice

orderDrink :: Monad m => Drink -> StockLiquorT m Receipt
orderDrink drink = do
  price <- demandDrink drink
  pure (Receipt drink price)

orderDrinks :: Monad m => [Drink] -> StockLiquorT m [Receipt]
orderDrinks drinks =
  case drinks of
    [] ->
      pure []

    firstDrink : restOfDrinks -> do
      firstReceipt <- orderDrink firstDrink
      restOfReceipts <- orderDrinks restOfDrinks
      pure (firstReceipt : restOfReceipts)

main :: IO ()
main = do
  let
    market = Map.fromList [(VodkaTonic, 18.00)]
    drinkList = replicate 5 RumAndCoke ++ replicate 3 VodkaTonic

  (receipts, finalMarket) <- runStockLiquorT (chargeForDrinks drinkList) market

  putStrLn ":: Drink Receipts ::"
  mapM_ print receipts

  putStrLn ":: Market ::"
  mapM_ print $ Map.toList finalMarket

chargeForDrinks :: [Drink] -> StockLiquorT IO [Receipt]
chargeForDrinks drinks = do
  receipts <- orderDrinks drinks

  connection <- Trans.lift openCreditCardAPIConnection
  _ <- traverse (chargeCard connection) receipts
  Trans.lift $ closeCreditCardAPIConnection connection

  pure receipts

chargeCard :: CreditCardAPIConnection -> Receipt -> StockLiquorT IO ()
chargeCard connection receipt = do
  if receiptPrice receipt > 100.00
     then do
       Trans.lift $ Exc.throw (OverpricedDrinkError receipt)
     else do
       Trans.lift $ callCreditCardAPI connection

openCreditCardAPIConnection :: IO CreditCardAPIConnection
openCreditCardAPIConnection = do
  putStrLn "++ Opening Connection to Credit Card API"
  pure CreditCardAPIConnection

closeCreditCardAPIConnection :: CreditCardAPIConnection -> IO ()
closeCreditCardAPIConnection _ =
  putStrLn "-- Closing Connection to Credit Card API"

callCreditCardAPI :: CreditCardAPIConnection -> IO ()
callCreditCardAPI _ =
  putStrLn " : Calling API"

data OverpricedDrinkError =
  OverpricedDrinkError Receipt
  deriving (Show, Typable.Typeable)

instance Exc.Exception OverpricedDrinkError

data CreditCardAPIConnection =
  CreditCardAPIConnection

StockLiquorTFinal.hs

module StockLiquorTFinal where

import qualified Control.Exception as Exc
import qualified Control.Monad.Trans as Trans
import qualified Data.Fixed as Fixed
import qualified Data.Map as Map
import qualified Data.Typeable as Typable

data Drink
  = VodkaTonic
  | RumAndCoke
  deriving (Show, Eq, Ord)

data Receipt =
  Receipt
    { receiptDrink :: Drink
    , receiptPrice :: Fixed.Centi
    } deriving Show

type Market = Map.Map Drink Fixed.Centi

newtype StockLiquorT m a =
  StockLiquorT
    { runStockLiquorT :: Market -> m (a, Market)
    }

instance Functor m => Functor (StockLiquorT m) where
  fmap f sl =
    StockLiquorT $ \market ->
      let
        mapResult (a, m) = (f a, m)
      in
        fmap mapResult $ runStockLiquorT sl market

instance Monad m => Applicative (StockLiquorT m) where
  pure =
    pureMarket

  slF <*> slA =
    linkMarket slF $ \f ->
    linkMarket slA $ \a ->
    pureMarket (f a)

instance Monad m => Monad (StockLiquorT m) where
  (>>=) = linkMarket

instance Trans.MonadTrans StockLiquorT where
  lift ma =
    StockLiquorT $ \market ->
      fmap (\a -> (a,market)) ma

linkMarket
  :: Monad m
  => StockLiquorT m a
  -> (a -> StockLiquorT m b)
  -> StockLiquorT m b
linkMarket marketToA aToB =
  StockLiquorT $ \market -> do
    (a, newMarket) <- runStockLiquorT marketToA market
    runStockLiquorT (aToB a) newMarket

pureMarket :: Applicative m => a -> StockLiquorT m a
pureMarket a =
  StockLiquorT $ \market -> pure (a, market)

getMarket :: Applicative m => StockLiquorT m Market
getMarket =
  StockLiquorT $ \market -> pure (market, market)

putMarket :: Applicative m => Market -> StockLiquorT m ()
putMarket newMarket =
  StockLiquorT $ \_ -> pure ((), newMarket)

marketDrinkPrice :: Drink -> Market -> Fixed.Centi
marketDrinkPrice drink market =
  Map.findWithDefault (defaultDrinkPrice drink) drink market

defaultDrinkPrice :: Drink -> Fixed.Centi
defaultDrinkPrice drink =
  case drink of
    VodkaTonic -> 16.80
    RumAndCoke ->  4.75

demandDrink :: Monad m => Drink -> StockLiquorT m Fixed.Centi
demandDrink drink = do
  market <- getMarket

  let
    thisPrice = marketDrinkPrice drink market
    nextPrice = thisPrice + 20.00
    newMarket = Map.insert drink nextPrice market

  putMarket newMarket
  pure thisPrice

orderDrink :: Monad m => Drink -> StockLiquorT m Receipt
orderDrink drink = do
  price <- demandDrink drink
  pure (Receipt drink price)

orderDrinks :: Monad m => [Drink] -> StockLiquorT m [Receipt]
orderDrinks drinks =
  case drinks of
    [] ->
      pure []

    firstDrink : restOfDrinks -> do
      firstReceipt <- orderDrink firstDrink
      restOfReceipts <- orderDrinks restOfDrinks
      pure (firstReceipt : restOfReceipts)

main :: IO ()
main = do
  let
    market = Map.fromList [(VodkaTonic, 18.00)]
    drinkList = replicate 6 RumAndCoke ++ replicate 3 VodkaTonic

  (receipts, finalMarket) <- runStockLiquorT (chargeForDrinks drinkList) market

  putStrLn ":: Drink Receipts ::"
  mapM_ print receipts

  putStrLn ":: Market ::"
  mapM_ print $ Map.toList finalMarket

chargeForDrinks :: [Drink] -> StockLiquorT IO [Receipt]
chargeForDrinks drinks = do
  receipts <- orderDrinks drinks

  connection <- Trans.lift openCreditCardAPIConnection

  _ <- traverse (tryChargeCard connection) receipts `finallySLT3`
         Trans.lift (closeCreditCardAPIConnection connection)

  pure receipts

{-
   This version of finally clearly conveys that the cleanup cannot touch the
   state. This is also a limitation -- the cleanup cannot touch the state!
-}
finallySLT :: StockLiquorT IO a -> IO b -> StockLiquorT IO a
finallySLT action cleanup =
  StockLiquorT $ \market ->
    runStockLiquorT action market `Exc.finally` cleanup

{-
   This version of finally gives the cleanup access to the state, but it is the
   original state, even in the case when the action succeeds. Any state changes
   made by the cleanup are lost, no matter what. This is at least consistent
   behavior however, not dependent on whether an exception happens.
-}
finallySLT2 :: StockLiquorT IO a -> StockLiquorT IO b -> StockLiquorT IO a
finallySLT2 action cleanup =
  StockLiquorT $ \market ->
    runStockLiquorT action market `Exc.finally`
      runStockLiquorT cleanup market

{-
   This version of finally gives access to the latest state and propagates
   the state changes forward, when it can. However, this means that the way
   in which the cleanup action interacts with the state is now inconsistent
   between when an exception happens and one does not.
-}
finallySLT3 :: StockLiquorT IO a -> StockLiquorT IO b -> StockLiquorT IO a
finallySLT3 action cleanup =
  StockLiquorT $ \market -> do
    (a, newMarket) <- runStockLiquorT action market `Exc.onException`
                        runStockLiquorT cleanup market
    (_, newMarket2) <- runStockLiquorT cleanup newMarket
    pure (a, newMarket2)

onExceptionSLT :: StockLiquorT IO a -> StockLiquorT IO b -> StockLiquorT IO a
onExceptionSLT action onExc =
  StockLiquorT $ \market ->
    runStockLiquorT action market `Exc.onException`
      runStockLiquorT onExc market

tryChargeCard :: CreditCardAPIConnection -> Receipt -> StockLiquorT IO ()
tryChargeCard connection receipt = do
  result <- trySLT $ chargeCard connection receipt
  case result of
    Left err ->
      Trans.lift $ print err

    Right _ ->
      pure ()


trySLT :: StockLiquorT IO a -> StockLiquorT IO (Either OverpricedDrinkError a)
trySLT action =
  StockLiquorT $ \market -> do
    result <- Exc.try $ runStockLiquorT action market

    case result of
      Right (a, newMarket) ->
        pure (Right a, newMarket)

      Left err ->
        pure (Left err, market)

catchSLT
  :: StockLiquorT IO a
  -> (OverpricedDrinkError -> StockLiquorT IO a)
  -> StockLiquorT IO a
catchSLT action onException = do
  StockLiquorT $ \market ->
    runStockLiquorT action market `Exc.catch`
      \exception -> runStockLiquorT (onException exception) market

chargeCard :: CreditCardAPIConnection -> Receipt -> StockLiquorT IO ()
chargeCard connection receipt = do
  if receiptPrice receipt > 100.00
     then do
       Trans.lift $ Exc.throw (OverpricedDrinkError receipt)
     else do
       Trans.lift $
         if receiptPrice receipt == 38.00
            then Exc.throw NetworkError
            else callCreditCardAPI connection

openCreditCardAPIConnection :: IO CreditCardAPIConnection
openCreditCardAPIConnection = do
  putStrLn "++ Opening Connection to Credit Card API"
  pure CreditCardAPIConnection

closeCreditCardAPIConnection :: CreditCardAPIConnection -> IO ()
closeCreditCardAPIConnection _ =
  putStrLn "-- Closing Connection to Credit Card API"

callCreditCardAPI :: CreditCardAPIConnection -> IO ()
callCreditCardAPI _ =
  putStrLn " : Calling API"

data OverpricedDrinkError =
  OverpricedDrinkError Receipt
  deriving (Show, Typable.Typeable)

instance Exc.Exception OverpricedDrinkError

data NetworkError =
  NetworkError
  deriving (Show, Typable.Typeable)

instance Exc.Exception NetworkError

data CreditCardAPIConnection =
  CreditCardAPIConnection