Merge pull request #15 from mtlstats/create-player

Create player

src/Mtlstats/Actions.hs

@@ -30,6 +30,8 @@ module Mtlstats.Actions
   , overtimeCheck
   , updateGameStats
   , validateGameDate
+  , createPlayer
+  , addPlayer
   ) where
 
 import Data.Maybe (fromMaybe)
@@ -111,3 +113,19 @@ validateGameDate s = fromMaybe s $ do
       .  (gameMonth .~ Nothing)
       .  (gameDay   .~ Nothing)
     else s
+
+-- | Starts player creation mode
+createPlayer :: ProgState -> ProgState
+createPlayer = progMode .~ CreatePlayer newCreatePlayerState
+
+-- | Adds the entered player to the roster
+addPlayer :: ProgState -> ProgState
+addPlayer s = fromMaybe s $ do
+  let cps = s^.progMode.createPlayerStateL
+  num <- cps^.cpsNumber
+  let
+    name   = cps^.cpsName
+    pos    = cps^.cpsPosition
+    player = newPlayer num name pos
+  Just $ s & database.dbPlayers
+    %~ (player:)

src/Mtlstats/Control.hs

@@ -53,6 +53,12 @@ dispatch s = case s^.progMode of
     | null $ gs^.overtimeFlag -> overtimeFlagC
     | not $ gs^.dataVerified  -> verifyDataC
     | otherwise               -> reportC
+  CreatePlayer cps
+    | null $ cps^.cpsNumber   -> getPlayerNumC
+    | null $ cps^.cpsName     -> getPlayerNameC
+    | null $ cps^.cpsPosition -> getPlayerPosC
+    | not $ cps^.cpsConfirmed -> confirmCreatePlayerC
+    | otherwise               -> undefined
 
 mainMenuC :: Controller
 mainMenuC = Controller
@@ -194,3 +200,46 @@ reportC = Controller
 header :: ProgState -> C.Update ()
 header s = C.drawString $
   "*** GAME " ++ padNum 2 (s^.database.dbGames) ++ " ***\n"
+
+getPlayerNumC :: Controller
+getPlayerNumC = Controller
+  { drawController   = drawPrompt playerNumPrompt
+  , handleController = \e -> do
+    promptHandler playerNumPrompt e
+    return True
+  }
+
+getPlayerNameC :: Controller
+getPlayerNameC = Controller
+  { drawController   = drawPrompt playerNamePrompt
+  , handleController = \e -> do
+    promptHandler playerNamePrompt e
+    return True
+  }
+
+getPlayerPosC :: Controller
+getPlayerPosC = Controller
+  { drawController   = drawPrompt playerPosPrompt
+  , handleController = \e -> do
+    promptHandler playerPosPrompt e
+    return True
+  }
+
+confirmCreatePlayerC :: Controller
+confirmCreatePlayerC = Controller
+  { drawController = \s -> do
+    let cps = s^.progMode.createPlayerStateL
+    C.drawString $ "  Player number: " ++ show (fromJust $ cps^.cpsNumber) ++ "\n"
+    C.drawString $ "    Player name: " ++ cps^.cpsName ++ "\n"
+    C.drawString $ "Player position: " ++ cps^.cpsPosition ++ "\n\n"
+    C.drawString "Create player: are you sure?  (Y/N)"
+    return C.CursorInvisible
+  , handleController = \e -> do
+    case ynHandler e of
+      Just True  -> do
+        modify addPlayer
+        modify $ progMode .~ MainMenu
+      Just False -> modify $ progMode .~ MainMenu
+      Nothing    -> return ()
+    return True
+  }

src/Mtlstats/Menu.hs

@@ -60,7 +60,9 @@ mainMenu = Menu "*** MAIN MENU ***" True
     modify startNewSeason >> return True
   , MenuItem '2' "New Game" $
     modify startNewGame >> return True
-  , MenuItem '3' "Exit" $
+  , MenuItem '3' "Create Player" $
+    modify createPlayer >> return True
+  , MenuItem '4' "Exit" $
     return False
   ]
 

src/Mtlstats/Prompt.hs

@@ -30,7 +30,10 @@ module Mtlstats.Prompt (
   gameDayPrompt,
   otherTeamPrompt,
   homeScorePrompt,
-  awayScorePrompt
+  awayScorePrompt,
+  playerNumPrompt,
+  playerNamePrompt,
+  playerPosPrompt
 ) where
 
 import Control.Monad (when)
@@ -120,5 +123,20 @@ awayScorePrompt :: Prompt
 awayScorePrompt = numPrompt "Away score: " $
   modify . (progMode.gameStateL.awayScore ?~)
 
+-- | Prompts for a new player's number
+playerNumPrompt :: Prompt
+playerNumPrompt = numPrompt "Player number: " $
+  modify . (progMode.createPlayerStateL.cpsNumber ?~)
+
+-- | Prompts for a new player's name
+playerNamePrompt :: Prompt
+playerNamePrompt = strPrompt "Player name: " $
+  modify . (progMode.createPlayerStateL.cpsName .~)
+
+-- | Prompts for a new player's position
+playerPosPrompt :: Prompt
+playerPosPrompt = strPrompt "Player position: " $
+  modify . (progMode.createPlayerStateL.cpsPosition .~)
+
 drawSimplePrompt :: String -> ProgState -> C.Update ()
 drawSimplePrompt pStr s = C.drawString $ pStr ++ s^.inputBuffer

src/Mtlstats/Types.hs

@@ -26,9 +26,10 @@ module Mtlstats.Types (
   Controller (..),
   Action,
   ProgState (..),
-  GameState (..),
   ProgMode (..),
+  GameState (..),
   GameType (..),
+  CreatePlayerState (..),
   Database (..),
   Player (..),
   PlayerStats (..),
@@ -43,6 +44,7 @@ module Mtlstats.Types (
   inputBuffer,
   -- ** ProgMode Lenses
   gameStateL,
+  createPlayerStateL,
   -- ** GameState Lenses
   gameYear,
   gameMonth,
@@ -53,6 +55,11 @@ module Mtlstats.Types (
   awayScore,
   overtimeFlag,
   dataVerified,
+  -- ** CreatePlayerState Lenses
+  cpsNumber,
+  cpsName,
+  cpsPosition,
+  cpsConfirmed,
   -- ** Database Lenses
   dbPlayers,
   dbGoalies,
@@ -89,6 +96,7 @@ module Mtlstats.Types (
   -- * Constructors
   newProgState,
   newGameState,
+  newCreatePlayerState,
   newDatabase,
   newPlayer,
   newPlayerStats,
@@ -152,6 +160,14 @@ data ProgState = ProgState
   -- ^ Buffer for user input
   } deriving (Eq, Show)
 
+-- | The program mode
+data ProgMode
+  = MainMenu
+  | NewSeason
+  | NewGame GameState
+  | CreatePlayer CreatePlayerState
+  deriving (Eq, Show)
+
 -- | The game state
 data GameState = GameState
   { _gameYear     :: Maybe Int
@@ -174,19 +190,24 @@ data GameState = GameState
   -- ^ Set to 'True' when the user confirms the entered data
   } deriving (Eq, Show)
 
--- | The program mode
-data ProgMode
-  = MainMenu
-  | NewSeason
-  | NewGame GameState
-  deriving (Eq, Show)
-
 -- | The type of game
 data GameType
   = HomeGame
   | AwayGame
   deriving (Eq, Show)
 
+-- | Player creation status
+data CreatePlayerState = CreatePlayerState
+  { _cpsNumber    :: Maybe Int
+  -- ^ The player's number
+  , _cpsName      :: String
+  -- ^ The player's name
+  , _cpsPosition  :: String
+  -- ^ The player's position
+  , _cpsConfirmed :: Bool
+  -- ^ Set when the user confirms the input
+  } deriving (Eq, Show)
+
 -- | Represents the database
 data Database = Database
   { _dbPlayers       :: [Player]
@@ -408,6 +429,7 @@ data Prompt = Prompt
 
 makeLenses ''ProgState
 makeLenses ''GameState
+makeLenses ''CreatePlayerState
 makeLenses ''Database
 makeLenses ''Player
 makeLenses ''PlayerStats
@@ -422,6 +444,13 @@ gameStateL = lens
     _          -> newGameState)
   (\_ gs -> NewGame gs)
 
+createPlayerStateL :: Lens' ProgMode CreatePlayerState
+createPlayerStateL = lens
+  (\case
+    CreatePlayer cps -> cps
+    _                -> newCreatePlayerState)
+  (\_ cps -> CreatePlayer cps)
+
 -- | Constructor for a 'ProgState'
 newProgState :: ProgState
 newProgState = ProgState
@@ -444,6 +473,15 @@ newGameState = GameState
   , _dataVerified = False
   }
 
+-- | Constructor for a 'CreatePlayerState'
+newCreatePlayerState :: CreatePlayerState
+newCreatePlayerState = CreatePlayerState
+  { _cpsNumber    = Nothing
+  , _cpsName      = ""
+  , _cpsPosition  = ""
+  , _cpsConfirmed = False
+  }
+
 -- | Constructor for a 'Database'
 newDatabase :: Database
 newDatabase = Database

test/ActionsSpec.hs

@@ -39,6 +39,8 @@ spec = describe "Mtlstats.Actions" $ do
   overtimeCheckSpec
   updateGameStatsSpec
   validateGameDateSpec
+  createPlayerSpec
+  addPlayerSpec
 
 startNewSeasonSpec :: Spec
 startNewSeasonSpec = describe "startNewSeason" $ do
@@ -315,6 +317,36 @@ validateGameDateSpec = describe "validateGameDate" $ do
       s^.progMode.gameStateL.gameMonth `shouldBe` Just 6
       s^.progMode.gameStateL.gameDay   `shouldBe` Nothing
 
+createPlayerSpec :: Spec
+createPlayerSpec = describe "createPlayer" $
+  it "should change the mode appropriately" $ let
+    s = createPlayer newProgState
+    in s^.progMode `shouldBe` CreatePlayer newCreatePlayerState
+
+addPlayerSpec :: Spec
+addPlayerSpec = describe "addPlayer" $ do
+  let
+    p1 = newPlayer 1 "Joe" "centre"
+    p2 = newPlayer 2 "Bob" "defense"
+    db = newDatabase
+      & dbPlayers .~ [p2]
+    s pm = newProgState
+      & progMode .~ pm
+      & database .~ db
+
+  context "data available" $
+    it "should create the player" $ let
+      s' = addPlayer $ s $ CreatePlayer $ newCreatePlayerState
+        & cpsNumber   ?~ 1
+        & cpsName     .~ "Joe"
+        & cpsPosition .~ "centre"
+      in s'^.database.dbPlayers `shouldBe` [p1, p2]
+
+  context "data unavailable" $
+    it "should not create the player" $ let
+      s' = addPlayer $ s MainMenu
+      in s'^.database.dbPlayers `shouldBe` [p2]
+
 makePlayer :: IO Player
 makePlayer = Player
   <$> makeNum

test/TypesSpec.hs

@@ -42,6 +42,7 @@ spec = describe "Mtlstats.Types" $ do
   gameStatsSpec
   databaseSpec
   gameStateLSpec
+  createPlayerStateLSpec
   teamScoreSpec
   otherScoreSpec
   homeTeamSpec
@@ -81,6 +82,23 @@ gameStateLSpec = describe "gameStateL" $ lensSpec gameStateL
   ]
   where gs t = newGameState & gameType ?~ t
 
+createPlayerStateLSpec :: Spec
+createPlayerStateLSpec = describe "createPlayerStateL" $
+  lensSpec createPlayerStateL
+  -- getters
+  [ ( MainMenu,              newCreatePlayerState )
+  , ( CreatePlayer $ cps 1 , cps 1                )
+  ]
+  -- setters
+  [ ( MainMenu,             cps 1 )
+  , ( CreatePlayer $ cps 1, cps 2 )
+  ]
+  where
+    cps n = newCreatePlayerState
+      & cpsNumber   ?~ n
+      & cpsName     .~ "foo"
+      & cpsPosition .~ "bar"
+
 teamScoreSpec :: Spec
 teamScoreSpec = describe "teamScore" $ do
   let