Remove constructor for errors to handle them in a MonadError instead and add a MonadWriter for logs

ChangeLog.md

@@ -1,5 +1,10 @@
 # Revision history for hanafuda
 
+## 0.3.1.0  -- 2019-01-08
+
+* Generalize the output monad of basic functions by only expressing constraints on it
+* Remove constructor for errors to handle them in a MonadError instead and add a MonadWriter for logs
+
 ## 0.3.0.2  -- 2018-08-27
 
 * Remove WillowRed accidentally present in plains' set

hanafuda.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                hanafuda
-version:             0.3.0.2
+version:             0.3.1.0
 synopsis:            A game of Hanafuda (a family of japanese card games)
 description:         This is a library to represent the cards and the players
                      of games in this family. It also implements one such game

src/Hanafuda/KoiKoi.hs

@@ -1,12 +1,16 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Hanafuda.KoiKoi (
-      Card(..)
+      Action(..)
+    , Card(..)
     , Game(..)
+    , Environment
     , Mode(..)
     , Move(..)
     , On(..)
     , Over(..)
     , Score
+    , Source(..)
     , Step(..)
     , Yaku(..)
     , new
@@ -16,29 +20,31 @@ module Hanafuda.KoiKoi (
 import Hanafuda (Card(..), Flower(Pine), contains, flower, match, remove)
 import qualified Hanafuda.Player as Player (players, random, scores)
 import Hanafuda.KoiKoi.Yaku (Yaku(..), Score)
-import Hanafuda.KoiKoi.Game (Game(..), Mode(..), Move(..), On(..), Over(..), Step(..), raise)
+import Hanafuda.KoiKoi.Game (Action(..), Environment, Game(..), Mode(..), Move(..), On(..), Over(..), Source(..), Step(..))
 import qualified Hanafuda.KoiKoi.Round as Round (deal, next)
 import qualified Hanafuda.KoiKoi.Turn as Turn (catch, end, next)
+import Control.Monad.Except (MonadError(..))
+import Control.Monad.IO.Class (MonadIO)
 
-play :: Ord player => Move -> On player -> IO (Game player)
+play :: (Environment m, Ord player) => Move -> On player -> m (Game player)
 play move on@(On_ {river, step}) =
   case (step, move) of
     (ToPlay, Play card) ->
-      either raise (Turn.catch on card) $ match card river
+      either throwError (Turn.catch on card) $ match card river
     (ToPlay, Capture (card, caught)) ->
       if card `canCatch` caught
         then Turn.catch on card (remove river caught, [card, caught])
-        else raise "You can't choose that card"
+        else throwError "You can't choose that card"
     (Turned card, Choose caught) ->
       if card `canCatch` caught
-        then Turn.end on (remove river caught, [card, caught])
+        then Turn.end on card (remove river caught, [card, caught])
-        else raise "You can't choose that card"
+        else throwError "You can't choose that card"
     (Scored, KoiKoi keepOn) -> (if keepOn then Turn.next else Round.next) on
-    (_, _) -> raise "You can't play this move in that state"
+    (_, _) -> throwError "You can't play this move in that state"
   where
     canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
 
-new :: Ord player => [player] -> Mode -> IO (On player)
+new :: (MonadIO m, Ord player) => [player] -> Mode -> m (On player)
 new playersList mode = do
   playing <- Player.random players
   Round.deal $ On_ {

src/Hanafuda/KoiKoi/Game.hs

@@ -1,17 +1,24 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
 module Hanafuda.KoiKoi.Game (
-      Game(..)
+      Action(..)
+    , Game(..)
+    , Environment
     , Mode(..)
     , Move(..)
     , On(..)
     , Over(..)
+    , Source(..)
     , Step(..)
     , end
-    , raise
     , setPlayer
     , stop
   ) where
 
+import Control.Monad.Except (MonadError)
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Writer (MonadWriter)
 import Hanafuda (Card, Flower, Pack)
 import Hanafuda.Player (Players, Player, Scores, set)
 import Hanafuda.KoiKoi.Yaku (Score)
@@ -19,6 +26,14 @@ import Hanafuda.KoiKoi.Yaku (Score)
 data Mode = FirstAt Int | WholeYear deriving (Show)
 data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
 data Step = ToPlay | Turned Card | Scored deriving (Show)
+data Source = Hand | Deck deriving (Show)
+data Action = Action {
+      source :: Source
+    , played :: Card
+    , captures :: Maybe Card
+  } deriving (Show)
+
+type Environment m = (MonadIO m, MonadError String m, MonadWriter [Action] m)
 
 data On player = On_ {
       mode :: Mode
@@ -37,16 +52,13 @@ data Over player = Over_ {
     finalScores :: Scores player
   } deriving (Show)
 
-data Game player = Error String | Over (Over player) | On (On player) deriving (Show)
+data Game player = Over (Over player) | On (On player) deriving (Show)
 
 setPlayer :: Ord player => On player -> Player player Score -> On player
 setPlayer on@(On_ {players, playing}) player = on {players = set playing player players}
 
-end :: Ord player => On player -> IO (Game player)
+end :: Monad m => On player -> m (Game player)
 end (On_ {scores}) = return . Over $ Over_ {finalScores = scores}
 
-stop :: Ord player => On player -> IO (Game player)
+stop :: Monad m => On player -> m (Game player)
 stop = return . On
-
-raise :: String -> IO (Game player)
-raise = return . Error

src/Hanafuda/KoiKoi/Round.hs

@@ -9,9 +9,10 @@ import Hanafuda.KoiKoi.Yaku (sumYakus)
 import Hanafuda.KoiKoi.Game (Game, Mode(..), On(..), Step(..), end, stop)
 import qualified Hanafuda.Player as Player (deal, get, next, score)
 import Data.Map ((!), insert)
+import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.State (replicateM, runState, state)
 
-deal :: Ord player => On player -> IO (On player)
+deal :: (MonadIO m, Ord player) => On player -> m (On player)
 deal on@(On_ {players}) = do
   ([hand1, hand2, river], deck) <- fmap (runState (replicateM 3 take8)) $ shuffle cards
   return on {
@@ -22,7 +23,7 @@ deal on@(On_ {players}) = do
   where
     take8 = state $ splitAt 8
 
-next :: Ord player => On player -> IO (Game player)
+next :: (MonadIO m, Ord player) => On player -> m (Game player)
 next on@(On_ {mode, scores, month, players, oyake, winning}) =
   case mode of
     FirstAt n | n <= newScore -> end scored

src/Hanafuda/KoiKoi/Turn.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Hanafuda.KoiKoi.Turn (
       catch
     , end
@@ -10,26 +11,40 @@ import Hanafuda (Card, Pack, empty, match)
 import Hanafuda.Player (Player(..), plays)
 import qualified Hanafuda.Player as Player (get, next)
 import Hanafuda.KoiKoi.Yaku (meldInto)
-import Hanafuda.KoiKoi.Game (Game, On(..), Step(..), raise, setPlayer, stop)
+import Hanafuda.KoiKoi.Game (Action(..), Environment, Game, On(..), Source(..), Step(..), setPlayer, stop)
 import qualified Hanafuda.KoiKoi.Round as Round (next)
+import Control.Monad.Except (MonadError(..))
+import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Reader (runReader)
+import Control.Monad.Writer (MonadWriter(..))
+import Prelude hiding (log)
 
-catch :: Ord player => On player -> Card -> (Pack, [Card]) -> IO (Game player)
+log :: MonadWriter [Action] m => Source -> Card -> [Card] -> m ()
-catch on@(On_ {players, playing}) card (river, trick) =
+log source played cards = tell [
-  either raise (popNextCard . setPlayer (on {river, trick})) played
+    Action { source, played, captures = captures cards }
+  ]
+  where
+    captures [_, captured] = Just captured
+    captures _ = Nothing
+
+catch :: (Environment m, Ord player) => On player -> Card -> (Pack, [Card]) -> m (Game player)
+catch on@(On_ {players, playing}) card (river, trick) = do
+  log Hand card trick
+  (setPlayer (on {river, trick})) <$> played >>= popNextCard
   where
     played = (Player.get playing players) `plays` card
 
-popNextCard :: Ord player => On player -> IO (Game player)
+popNextCard :: (Environment m, Ord player) => On player -> m (Game player)
-popNextCard (On_ {deck = []}) = raise "No more cards in the stack"
+popNextCard (On_ {deck = []}) = throwError "No more cards in the stack"
 popNextCard on@(On_ {river, deck = turned : others}) =
   let pop = on {deck = others} in
   case match turned river of
-    Right (newRiver, newCaptured) -> end pop (newRiver, newCaptured)
+    Right (newRiver, newCaptured) -> end pop turned (newRiver, newCaptured)
     Left _ -> stop $ pop {step = Turned turned}
 
-end :: Ord player => On player -> (Pack, [Card]) -> IO (Game player)
+end :: (MonadWriter [Action] m, MonadIO m, Ord player) => On player -> Card -> (Pack, [Card]) -> m (Game player)
-end on@(On_ {month, trick, playing, players}) (river, newCaptured) = do
+end on@(On_ {month, trick, playing, players}) card (river, newCaptured) = do
+  log Deck card newCaptured
   let updatedGame = setPlayer (on {river, trick = []}) updatedPlayer
   if null scored
     then next updatedGame
@@ -40,7 +55,7 @@ end on@(On_ {month, trick, playing, players}) (river, newCaptured) = do
     (scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month
     updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)}
 
-next :: Ord player => On player -> IO (Game player)
+next :: (MonadIO m, Ord player) => On player -> m (Game player)
 next on@(On_ {players, playing}) =
   let newPlaying = Player.next players playing in
   if hand (Player.get newPlaying players) == empty