Free FSM! An implementation of finite state machines as in https://wickstrom.tech/finite-state-machines/2017/11/19/finite-state-machines-part-2.html using Free monads

FreeFSM.hs

#!/usr/bin/env stack
-- stack script --resolver lts-9.14 --package free
{-# LANGUAGE GADTs, DeriveFunctor #-}

type CartItem =
  String


type CreditCard =
  String


type OrderId =
  Integer


data CheckoutProtocolF s r
  = Start r
  | Select (CartItem -> r)
  | Checkout (CheckoutState HasItems) r
  | Cancel (CancelState s) (CheckoutState HasItems -> r)
  | SelectCard (CheckoutState NoCard) (CreditCard -> r)
  | Confirm (CheckoutState CardSelected) r
  | PlaceOrder (CheckoutState CardConfirmed) (OrderId -> r)
  | Finish r
  deriving Functor


data CheckoutInteractionF s r
  = AskSelectMore (SelectState s) (Bool -> r)
  | AskConfirmCard CreditCard (Bool -> r)
  deriving Functor


data CheckoutF s r
  = Protocol (CheckoutProtocolF s r)
  | Interaction (CheckoutInteractionF s r)
  deriving Functor


type CheckoutM s =
  Free (CheckoutF s)


data NoItems
data HasItems
data NoCard
data CardSelected
data CardConfirmed
data OrderPlaced


data SelectState s
  = NoItemsSelect (CheckoutState NoItems)
  | HasItemsSelect (CheckoutState HasItems)


data CancelState s
  = NoCardCancel (CheckoutState NoCard)
  | CardSelectedCancel (CheckoutState CardSelected)
  | CardConfirmedCancel (CheckoutState CardConfirmed)


data CheckoutState s where
  NoItems
    :: CheckoutState NoItems

  HasItems
    :: NonEmpty CartItem
    -> CheckoutState HasItems

  NoCard
    :: NonEmpty CartItem
    -> CheckoutState NoCard

  CardSelected
    :: NonEmpty CartItem
    -> CreditCard
    -> CheckoutState CardSelected

  CardConfirmed
    :: NonEmpty CartItem
    -> CreditCard
    -> CheckoutState CardConfirmed

  OrderPlaced
    :: OrderId
    -> CheckoutState OrderPlaced


initial :: CheckoutM s (CheckoutState NoItems)
initial =
  liftF $ Protocol (Start NoItems)


askSelectMore :: SelectState s -> CheckoutM s Bool
askSelectMore sst =
  liftF $ Interaction (AskSelectMore sst id)


select :: SelectState s -> CheckoutM s (CheckoutState HasItems)
select (NoItemsSelect NoItems) =
  liftF $ Protocol $ Select (\i -> HasItems (i :| []))
select (HasItemsSelect (HasItems is)) =
  liftF $ Protocol $ Select (\i -> HasItems (i <| is))


checkout :: CheckoutState HasItems -> CheckoutM s (CheckoutState NoCard)
checkout items@(HasItems is) =
  liftF $ Protocol $ Checkout items (NoCard is)


selectCard :: CheckoutState NoCard -> CheckoutM s (CheckoutState CardSelected)
selectCard cst@(NoCard is) =
  liftF $ Protocol $ SelectCard cst (CardSelected is)


askConfirm :: CheckoutState CardSelected -> CheckoutM s Bool
askConfirm (CardSelected _ cc) =
  liftF $ Interaction $ AskConfirmCard cc id


confirm :: CheckoutState CardSelected -> CheckoutM s (CheckoutState CardConfirmed)
confirm st@(CardSelected is cc) =
  liftF $ Protocol $ Confirm st (CardConfirmed is cc)


placeOrder :: CheckoutState CardConfirmed -> CheckoutM s (CheckoutState OrderPlaced)
placeOrder st =
  liftF $ Protocol $ PlaceOrder st OrderPlaced


cancel :: CancelState s -> CheckoutM s (CheckoutState HasItems)
cancel (NoCardCancel (NoCard items)) =
  select $ HasItemsSelect (HasItems items)
cancel (CardSelectedCancel (CardSelected items _card)) =
  select $ HasItemsSelect (HasItems items)
cancel (CardConfirmedCancel (CardConfirmed cart _)) =
  select $ HasItemsSelect (HasItems cart)


end :: CheckoutState OrderPlaced -> CheckoutM s OrderId
end (OrderPlaced oid) =
  liftF $ Protocol (Finish oid)


checkoutProgram :: CheckoutM s OrderId
checkoutProgram =
  initial >>= fillCart >>= startCheckout >>= end
  where
    fillCart :: CheckoutState NoItems -> CheckoutM s (CheckoutState HasItems)
    fillCart st =
      -- `initial` doesn't type-check!
      select (NoItemsSelect st) >>= selectMoreItems

    selectMoreItems :: CheckoutState HasItems -> CheckoutM s (CheckoutState HasItems)
    selectMoreItems st = do
      more <- askSelectMore (HasItemsSelect st)
      if more then select (HasItemsSelect st) >>= selectMoreItems else return st

    startCheckout :: CheckoutState HasItems -> CheckoutM s (CheckoutState OrderPlaced)
    startCheckout (HasItems items) = do
      st@(CardSelected items cc) <- selectCard (NoCard items)
      useCard <- askConfirm st
      if useCard then confirm st >>= placeOrder else redo (CardSelectedCancel st)
      where
        redo st =
          cancel st >>= selectMoreItems >>= startCheckout


terminalInterpreter :: CheckoutM s res -> IO res
terminalInterpreter =
  foldFree morph
  where
    p :: [Char] -> IO ()
    p =
      print

    morph :: CheckoutF s res -> IO res
    morph (Protocol (Start next)) =
      p "Welcome!" >> return next
    morph (Interaction (AskSelectMore s next)) =
      p "More items? (y/n)" >> getLine >>= return . next . (=="y")
    morph (Protocol (Select next)) =
      loop
      where
        loop = do
          p "Enter item:"
          xs <- getLine
          if null xs
            then p "Invalid item" >> loop
            else p ("'" ++ xs ++ "' selected") >> return (next xs)
    morph (Protocol (Confirm _ next)) =
      return next
    morph (Protocol (Checkout (HasItems is) next)) =
      p (show is) >> return next
    morph (Protocol (Cancel st next)) =
      case st of
        NoCardCancel (NoCard is) ->
          return $ next (HasItems is)

        CardSelectedCancel (CardSelected is _) ->
          return $ next (HasItems is)

        CardConfirmedCancel (CardConfirmed is _) ->
          return $ next (HasItems is)
    morph (Interaction (AskConfirmCard cc next)) =
      p ("Confirm use of '" ++ cc ++ "' (y/n)?") >> getLine >>= return . next . (== "y")
    morph (Protocol (PlaceOrder (CardConfirmed is cc) next)) = do
      oid <- placeOrderApi
      print $ "Order nr. " ++ show oid
        ++ " placed! Congrats you just bought: " ++ show is
        ++ " (using your credit card: " ++ cc ++ ")"
      return $ next oid
      where
        placeOrderApi :: IO Integer
        placeOrderApi =
          return 6
    morph (Protocol (SelectCard (NoCard items) next)) =
      p "Enter card:" >> getLine >>= return . next
    morph (Protocol (Finish next)) =
      p "Goodbye!" >> return next


runCheckout :: IO OrderId
runCheckout =
  terminalInterpreter checkoutProgram

FreeFSM_firstTry.hs

#!/usr/bin/env stack
-- stack script --resolver lts-9.14 --package free
{-# LANGUAGE DataKinds, KindSignatures, DeriveFunctor #-}
import Control.Monad.Free
import qualified System.IO as IO
import Data.List.NonEmpty ((<|), NonEmpty(..))


type CartItem =
  String


type CreditCard =
  String


type OrderId =
  Integer


data ItemsState
  = NoItems
  | HasItems


data SelectState (a :: ItemsState)
  = NoItems'
  | HasItems' (NonEmpty CartItem)

-- newtype SelectState (a :: ItemsState) = C [CartItem]


data CardState
  = NoCard
  | CardSelected
  | CardConfirmed


data CancelState (a :: CardState)
  = NoCard' (NonEmpty CartItem)
  | CardSelected' (NonEmpty CartItem) CreditCard
  | CardConfirmed' (NonEmpty CartItem) CreditCard



data CheckoutF a b r
  = AskConfirmCard (CancelState 'CardSelected) (Bool -> r)
  | AskSelectMore (Bool -> r)
  -- | AskSelectMore (SelectState a) (Bool -> r)
  | Start r
  | Select (CartItem -> r)
  | Checkout (SelectState 'HasItems) r
  | Cancel (CancelState b) (SelectState 'HasItems -> r)
  | SelectCard (CancelState 'NoCard) (CreditCard -> r)
  | ConfirmCard (CancelState 'CardSelected) r
  | PlaceOrder (CancelState 'CardConfirmed) (OrderId -> r)
  | Finish r
  deriving (Functor)


type CheckoutM a b =
  Free (CheckoutF a b)


initial :: CheckoutM a b (SelectState 'NoItems)
initial =
  liftF $ Start NoItems'


askSelectMore :: CheckoutM a b Bool
askSelectMore =
  liftF $ AskSelectMore id


-- liftF cannot build a monad instance with this type signature
-- askSelectMore :: SelectState whatever -> CheckoutM a b Bool
-- askSelectMore sst = liftF $ AskSelectMore sst id


-- FIX: this type signature doesn't seem right
select :: SelectState whatever -> CheckoutM a b (SelectState 'HasItems)
select NoItems' =
  liftF $ Select (\i -> HasItems' (i :| []))
select (HasItems' is) =
  liftF $ Select (\i -> HasItems' (i <| is))


-- FIX: pattern non-exhaustive
checkout :: SelectState 'HasItems -> CheckoutM a b (CancelState 'NoCard)
checkout cart@(HasItems' is) =
  liftF $ Checkout cart (NoCard' is)


-- FIX: pattern non-exhaustive
selectCard :: CancelState 'NoCard -> CheckoutM a b (CancelState 'CardSelected)
selectCard cst@(NoCard' is) =
  liftF $ SelectCard cst (CardSelected' is)


-- FIX: pattern non-exhaustive
askConfirmCard :: CancelState 'CardSelected -> CheckoutM a b Bool
askConfirmCard cst =
  liftF $ AskConfirmCard cst id


-- FIX: pattern non-exhaustive
confirmCard :: CancelState 'CardSelected -> CheckoutM a b (CancelState 'CardConfirmed)
confirmCard cst@(CardSelected' is cc) =
  liftF $ ConfirmCard cst (CardConfirmed' is cc)


placeOrder :: CancelState 'CardConfirmed -> CheckoutM a b OrderId
placeOrder cst =
  liftF $ PlaceOrder cst id


-- FIX: this type signature doesn't seem right
cancel :: CancelState whatever -> CheckoutM a b (SelectState 'HasItems)
cancel (NoCard' cart) =
  select $ HasItems' cart
cancel (CardSelected' cart _) =
  select $ HasItems' cart
cancel (CardConfirmed' cart _) =
  select $ HasItems' cart


end :: OrderId -> CheckoutM a b ()
end _oid =
  liftF $ Finish ()


checkoutProgram :: CheckoutM a b ()
checkoutProgram =
  initial >>= fillCart >>= startCheckout >>= end
  where
    fillCart :: SelectState 'NoItems -> CheckoutM a b (CancelState 'NoCard)
    fillCart sst =
      -- `initial` doesn't type-check! 🎉
      select sst >>= selectMoreItems

    selectMoreItems :: SelectState 'HasItems -> CheckoutM a b (CancelState 'NoCard)
    selectMoreItems sst =
      askSelectMore >>= \more -> if more
                                 then select sst >>= selectMoreItems
                                 else checkout sst

    -- FIX: pattern non-exhaustive
    startCheckout :: CancelState 'NoCard -> CheckoutM a b OrderId
    startCheckout cst = do
      cst' <- selectCard cst
      useCard <- askConfirmCard cst'
      if useCard then confirmCard cst' >>= placeOrder else redo cst'
      where
        redo cst' =
          cancel cst' >>= selectMoreItems >>= startCheckout


terminalInterpreter :: CheckoutM a b res -> IO res
terminalInterpreter =
  foldFree morph
  where
    -- FIX: pattern non-exhaustive
    morph :: CheckoutF a b res -> IO res
    morph (Start next) =
      print "Welcome!" >> return next
    morph (AskSelectMore next) =
      print "More items? (y/n)" >> getLine >>= return . next . (=="y")
    morph (Select next) =
      loop
      where
        loop = do
          print "Enter item:"
          xs <- getLine
          if null xs
            then print "Invalid item" >> loop
            else print ("'" ++ xs ++ "' selected") >> return (next xs)
    morph (ConfirmCard _ next) =
      return next
    morph (Checkout (HasItems' is) next) =
      print is >> return next
    morph (Cancel cst next) =
      case cst of
        NoCard' is ->
          return $ next (HasItems' is)

        CardSelected' is _ ->
          return $ next (HasItems' is)

        CardConfirmed' is _ ->
          return $ next (HasItems' is)
    morph (SelectCard _ next) =
      print "Enter card:" >> getLine >>= return . next
    morph (AskConfirmCard (CardSelected' _is cc) next) =
      print ("Confirm use of '" ++ cc ++ "' (y/n)?") >> getLine >>= return . next . (== "y")
    morph (PlaceOrder (CardConfirmed' is cc) next) = do
      oid <- placeOrderApi
      print $ "Order nr. " ++ show oid
        ++ " placed! Congrats you just bought: " ++ show is
        ++ " (using your credit card: " ++ cc ++ ")"
      return $ next oid
      where
        placeOrderApi :: IO Integer
        placeOrderApi =
          return 6
    morph (Finish next) =
      print "Goodbye!" >> return next


runCheckout :: IO ()
runCheckout =
  terminalInterpreter checkoutProgram