From 561ef5060de1bd67146dceafd02af6804b2020e8 Mon Sep 17 00:00:00 2001
From: Tissevert <sasha+frama@marvid.fr>
Date: Tue, 8 Jan 2019 22:34:29 +0100
Subject: [PATCH] Generalize the output monad of basic functions by only
 expressing constraints on it

---
 src/Hanafuda.hs        |  5 +++--
 src/Hanafuda/Player.hs | 15 ++++++++++-----
 2 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/src/Hanafuda.hs b/src/Hanafuda.hs
index b8f8da8..e1fe004 100644
--- a/src/Hanafuda.hs
+++ b/src/Hanafuda.hs
@@ -29,6 +29,7 @@ import Data.Bits (
     , countTrailingZeros
   )
 import System.Random (randomRIO)
+import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (Reader)
 
 data Flower =
@@ -116,13 +117,13 @@ sameMonth card = Pack $ 0xf `shift` (fromEnum card .&. 0xfc)
 cards :: [Card]
 cards = [Pine0 .. Phoenix]
 
-shuffle :: [a] -> IO [a]
+shuffle :: MonadIO m => [a] -> m [a]
 shuffle l =
   aux (length l) l
   where
     aux _ [] = return []
     aux n (h:t) = do
-      cut <- randomRIO (0, n-1)
+      cut <- liftIO $ randomRIO (0, n-1)
       shuffled <- shuffle t
       let (top, bottom) = splitAt cut shuffled
       return $ top ++ h : bottom
diff --git a/src/Hanafuda/Player.hs b/src/Hanafuda/Player.hs
index f907917..1744a78 100644
--- a/src/Hanafuda/Player.hs
+++ b/src/Hanafuda/Player.hs
@@ -1,9 +1,12 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Hanafuda.Player where
 
 import Hanafuda (Card, Pack, contains, packOfCards, remove)
 import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size)
 import qualified Data.Map as Map (filter)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Except (MonadError(..))
 import System.Random (Random(..))
 
 data Player key yakus = Player {
@@ -35,9 +38,11 @@ players (alice:others@(bob:_)) =
 next :: Ord key => Players key yakus -> key -> key
 next (Players playersByKey) = nextPlayer . (playersByKey !)
 
-random :: Players key yakus -> IO key
+random :: MonadIO m => Players key yakus -> m key
 random (Players playersByKey) =
-  fst . ($ playersByKey) . elemAt <$> randomRIO (0, size playersByKey - 1)
+  fst . ($ playersByKey) . elemAt <$> randomIndex
+  where
+    randomIndex = liftIO $ randomRIO (0, size playersByKey - 1)
 
 get :: Ord key => key -> Players key yakus -> Player key yakus
 get key (Players playersByKey) = playersByKey ! key
@@ -52,11 +57,11 @@ deal (Players playersByKey) hands =
     setHand cards (Player {nextPlayer}) = (new nextPlayer) {hand = packOfCards cards}
     dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m)
 
-plays :: Player key yakus -> Card -> Either String (Player key yakus)
+plays :: MonadError String m => Player key yakus -> Card -> m (Player key yakus)
 plays player@(Player {hand}) card =
   if hand `contains` card
-    then Right $ player {hand = remove hand card}
-    else Left "You don't have this card"
+    then return $ player {hand = remove hand card}
+    else throwError "You don't have this card"
 
 type Points = Int
 type Scores key = Map key Points