free-monad.hs

free-monad.hs

{-# LANGUAGE DeriveFunctor #-}

module FreeMonadDI where

import Control.Monad.Free
import Data.IORef

data Product = Product { name :: String, price :: Double }
  deriving (Show, Eq)

data Cart = Cart { cartId :: Int, products :: [Product] }
  deriving (Show, Eq)

getCartApi :: Int -> Cart
getCartApi cid = Cart cid [Product "book" 42.0, Product "keyboard" 350.99]

data ProgramF next
  = GetCart Int (Cart -> next)
  | WriteLine String (() -> next)
  deriving (Functor)

type Program = Free ProgramF

getCart :: Int -> Program Cart
getCart cid = liftF $ GetCart cid id

writeLine :: String -> Program ()
writeLine s = liftF $ WriteLine s id

program :: Program Double
program = do
  let cid = 42
  cart <- getCart cid
  if length (products cart) > 10
    then do
      writeLine "Too many, I am sorry"
      return 0.0
    else
      return $ sum $ map price (products cart)

interpret :: Program a -> IO a
interpret = foldFree go
  where
    go (GetCart cid next) = return $ next (getCartApi cid)
    go (WriteLine s next) = putStrLn s >> return (next ())

testInterpret :: IORef String -> Program a -> IO a
testInterpret outRef = foldFree go
  where
    go (GetCart cid next) = return $ next (getCartTest cid)
    go (WriteLine s next) = writeIORef outRef s >> return (next ())
    
    getCartTest _ = Cart 42 (replicate 100 (Product "test product" 1.0))

main :: IO ()
main = do
  result <- interpret program
  putStrLn $ "Result: " ++ show result

testMain :: IO ()
testMain = do
  outRef <- newIORef ""
  result <- testInterpret outRef program
  output <- readIORef outRef
  putStrLn $ "Test result: " ++ show result
  putStrLn $ "Test output: " ++ output