Haskell: Tic-Tac-Toe console-based game

TicTacToe.hs

{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
import           Control.Monad
import           Data.Char
import           Data.List
import           Data.List.Split
import           Data.Map        (Map)
import qualified Data.Map        as Map
import           Text.Read

data Position = A | B | C
              | D | E | F
              | G | H | I
              deriving (Show, Eq, Ord, Enum, Bounded, Read)

data Piece = X | O | Blank
           deriving (Eq)

-- Our game board is modeled as a Map from a Position -> Piece
newtype Board = Board (Map Position Piece)

-- Helper function to pull out the Map from our Board type
getBoard :: Board -> Map Position Piece
getBoard (Board mp) = mp

-- Provide a custom string representation of each Piece
instance Show Piece where
  show X     = "X"
  show O     = "O"
  show Blank = "_"

-- A board where each Position is Blank
newBoard :: Board
newBoard = Board $ Map.fromAscList [(p,Blank) | p <- positions]

-- Enumerate all Positions (A,B,C...)
positions :: [Position]
positions  = [minBound..maxBound] :: [Position]


-- Get the rows from our board
rows :: Board -> [[Piece]]
rows board = chunksOf 3 $ Map.elems (getBoard board)

-- Get the columns by transposing the rows
cols :: Board -> [[Piece]]
cols b = transpose (rows b)

-- Get the left and right diagonals by zipping along the rows
diags :: Board -> [[Piece]]
diags b = [ zipWith (!!) (rows b) [0..]
          , zipWith (!!) (reverse $ rows b) [0..]
          ]

-- Put a piece on the board at the given position
put :: Piece -> Position -> Board -> Board
put piece pos (Board mp) = Board $ Map.insert pos piece mp

-- Lookup position on board
(!) :: Position -> Board -> Maybe Piece
(!) pos board = Map.lookup pos (getBoard board)

-- Scan a lane (a row, col, or diag) for three identical pieces
checkLane :: forall a t. Eq a => a -> t -> (t -> [[a]]) -> Bool
checkLane piece board lane = any (all (== piece)) $ lane board

-- Check if any row, column or diagonal (i.e. lanes) contains identical pieces
win :: Piece -> Board -> Bool
win piece board = or winningLane
    where winningLane = map (checkLane piece board) [rows, cols, diags]

-- Returns true if the cell is blank
free :: Position -> Board -> Bool
free pos board = (pos ! board) == Just Blank

-- Cycle player turns
next :: Piece -> Piece
next X = O
next O = X

-- Ask the user where to move (A,B,C...). If the position is invalid, ask again
askMove :: Show a => a -> IO Position
askMove player = do
  putStrLn $ "\nPlayer: " ++ show player ++ ", where would you like to move?"
  putStrLn $ showPositions ++ "\n"

  input <- liftM (map toUpper) getLine

  let parse = readEither input :: Either String Position

  case parse of
    Right pos -> putStrLn "" >> return pos
    Left  _   -> askMove player

-- Start game loop. Player X goes first.
startGame :: IO ()
startGame = move X newBoard where
  move p board =
    if  | win (next p) board -> putStrLn $ "Player " ++ show (next p) ++ " wins!"
        | otherwise -> do

            pos <- askMove p
            let valid = free pos board

            if | not valid -> putStrLn "Try again." >> move p board
               | valid -> do

                   let board' = put p pos board
                   putStrLn (showBoard board')
                   move (next p) board'

-- Pretty print board positions
showPositions :: String
showPositions = unlines $ map (++ "\n") eachRow
  where eachRow = map show (chunksOf 3 positions)

-- Pretty print the current board
showBoard :: Board -> String
showBoard b = unlines $ map (++ "\n") eachRow
  where eachRow = map show (rows b)

-- Main entry point
main :: IO ()
main = do
    putStrLn "*-*-* Tic Tac Toe *-*-*"
    startGame
    
{-
OUTPUT:
*-*-* Tic Tac Toe *-*-*
Player: X, where would you like to move?
[A,B,C]
[D,E,F]
[G,H,I]

a

[X,_,_]
[_,_,_]
[_,_,_]

Player: O, where would you like to move?
[A,B,C]
[D,E,F]
[G,H,I]

d

[X,_,_]
[O,_,_]
[_,_,_]

Player: X, where would you like to move?
[A,B,C]
[D,E,F]
[G,H,I]

e

[X,_,_]
[O,X,_]
[_,_,_]

Player: O, where would you like to move?
[A,B,C]
[D,E,F]
[G,H,I]

h

[X,_,_]
[O,X,_]
[_,O,_]

Player: X, where would you like to move?
[A,B,C]
[D,E,F]
[G,H,I]

i

[X,_,_]
[O,X,_]
[_,O,X]

Player X wins!
-}