Haskell Text-Adventure Game

Question

I just started making a text adventure game in Haskell. Because this is the largest project I have done in Haskell, I wanted to ask about it here before I got too far on it. I am still pretty new to Haskell, so I would really appreciate any advice at all on how this could be improved.

To compile the game, I just used ghc Main.

Here is my code:

Main.hs

import System.IO (hFlush, stdout)
import Control.Monad (unless, when, guard)
import Control.Applicative ((<|>), (<*>))
import Data.Maybe (fromMaybe, isJust, fromJust)
import Control.Monad.State
import Data.Char (isSpace)
import Room (Room)
import qualified Room as Room
import Game (Game, GameState)
import qualified Game as Game
import Direction
import Item (Item)
import qualified Item as Item
type GameResponse = IO (String, Game)
trim :: String -> String
trim = foldr pickChars []
 where
 pickChars ' ' (' ':xs) = ' ':xs
 pickChars c1 (x:xs) = c1:x:xs
 pickChars c1 [] = [c1]
travel :: Direction -> GameState
travel d = state $ \g -> fromMaybe ("You can't go that way.", g)
 (flip runState g . Game.enterRoom <$>
 Room.roomInDirection d (Game.currentRoom g))
main = do
 (msg, _) <- play . return $ runState Game.initGame Game.gameData
 putStrLn msg
play :: GameResponse -> GameResponse
play x = do
 (msg, gameData) <- x
 unless (null msg) $ putStrLn msg >> putStrLn ""
 putStr "> "
 hFlush stdout
 response <- trim <$> getLine
 if response `elem` ["q", "quit"]
 then return ("Adiós!", gameData)
 else play . return $ runState (exec response) gameData
exec :: String -> GameState
exec "look" = state $ \g -> (Room.nameWithDescription $ Game.currentRoom g, g)
exec s
 | isJust direction = travel (fromJust direction)
 | take 4 s == "take" || take 3 s == "get" = Game.takeItem s
 | s `elem` ["i", "inv", "inventory"] = Game.displayInv
 | s `elem` [" ", ""] = return ""
 | otherwise = return "What?"
 where
 direction = directionFromString s

Direction.hs

module Direction
( Direction(..)
, directionFromString
) where
import Data.Char (toLower)
data Direction = North | NorthEast | East | SouthEast 
 | South | SouthWest | West | NorthWest
 deriving (Show, Eq, Ord)
directionFromString :: String -> Maybe Direction
directionFromString s
 | d `elem` ["n", "north"] = return North
 | d `elem` ["ne", "northeast", "north east"] = return NorthEast
 | d `elem` ["e", "east"] = return East
 | d `elem` ["se", "southeast", "south east"] = return SouthEast
 | d `elem` ["s", "south"] = return South
 | d `elem` ["sw", "southwest", "south west"] = return SouthWest
 | d `elem` ["w", "west"] = return West
 | d `elem` ["nw", "northwest", "north west"] = return NorthWest
 | otherwise = Nothing
 where d = map toLower s 

Room.hs

module Room
( Room(..)
, roomInDirection
, look
, nameWithDescription
, removeItem
, findItem
) where
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.List (find, isInfixOf, delete)
import Direction
import Item (Item)
import qualified Item as Item
data Room = Room
 { name :: String
 , description :: String
 , directions :: Map Direction String
 , visited :: Bool
 , items :: [Item]
 } deriving (Show, Eq)
roomInDirection :: Direction -> Room -> Maybe String
roomInDirection d r = Map.lookup d (directions r)
nameWithDescription :: Room -> String
nameWithDescription r = name r ++ '\n':(description r)
look :: Room -> IO ()
look = putStrLn . nameWithDescription
findItem :: String -> Room -> Maybe Item
findItem n = find (\i -> isInfixOf (Item.name i) n) . items
removeItem :: Item -> Room -> Room
removeItem i r = r { items = delete i (items r) }

Item.hs

module Item 
( Item(..)
) where
data Item = Item
 { name :: String
 } deriving (Show, Eq)

Game.hs

module Game 
( Game(..)
, GameState
, find
, enterRoom
, gameData
, initGame
, takeItem
, displayInv
) where
import Data.Map.Strict (Map, (!))
import qualified Data.Map.Strict as Map
import Control.Monad.State
import Data.Maybe (fromMaybe)
import Direction
import Item (Item)
import qualified Item as Item
import Room (Room)
import qualified Room as Room
type GameState = State Game String
data Game = Game
 { currentRoom :: Room
 , roomMap :: Map String Room
 , inventory :: [Item]
 } deriving Show
gameData = Game { roomMap = Map.fromList
 [("corridor",
 Room.Room { Room.name = "Corridor"
 , Room.description = "ayyyy"
 , Room.directions = Map.fromList [
 (North, "dining hall") ]
 , Room.visited = False
 , Room.items = []
 })
 ,("dining hall",
 Room.Room { Room.name = "Dining Hall"
 , Room.description = "good food is here"
 , Room.directions = Map.fromList [
 (South, "corridor") ]
 , Room.visited = False
 , Room.items = [
 Item.Item { Item.name = "apple" } ]
 })
 ]
 , currentRoom = undefined
 , inventory = []
 }
find :: String -> Game -> Room
find n g = (roomMap g) ! n
enterRoom :: String -> GameState
enterRoom n =
 state $ \g ->
 (msg g
 , g { roomMap = Map.update (\x -> Just (x { Room.visited = True })) n (roomMap g),
 currentRoom = r g })
 where 
 r g = find n g
 msg g
 | Room.visited (r g) = Room.name (r g)
 | otherwise = Room.nameWithDescription (r g)
initGame :: GameState
initGame = enterRoom "corridor"
removeItemFromCurrentRoom :: Item -> GameState
removeItemFromCurrentRoom i = state $ \g ->
 ("Taken!", g { currentRoom = Room.removeItem i (currentRoom g), inventory = i:(inventory g) })
takeItem :: String -> GameState
takeItem n = state $ \g -> fromMaybe ("Item not found", g)
 (flip runState g . removeItemFromCurrentRoom
 <$> Room.findItem n (currentRoom g))
displayInv :: GameState
displayInv = state $ \g -> (safeInit . unlines . fmap Item.name . inventory $ g , g)
 where safeInit [] = []
 safeInit xs = init xs

Answer 1

The last two lines of pickChars collapse to pickChars c xs = c:xs. trim = unwords . words may be to your liking.

StateT can handle play's state-passery, but you'll have to redefine GameState as Monad m => StateT Game m String to allow play's IO actions.

main = putStrLn =<< evalStateT (Game.initGame >>= play) Game.gameData
play :: StateT Game IO String
play msg = do
 unless (null msg) $ putStrLn msg >> putStrLn ""
 putStr "> "
 hFlush stdout
 response <- trim <$> getLine
 if response `elem` ["q", "quit"]
 then return "Adiós!"
 else exec response >>= play

exec "look" = gets $ Room.nameWithDescription . Game.currentRoom

| Just direction <- directionFromString s = travel direction

You don't seem to be using State's monad instance. State's purpose is for you to not need to pass gamestates around manually! Doing state $ \s -> runState everywhere misses the point.

lens can help with nested data structures. An example:

data Room = Room
 { _name :: String
 , _description :: String
 , _directions :: Map Direction String
 , _visited :: Bool
 , _items :: [Item]
 } _deriving (Show, Eq)
makeFields ''Room
find :: String -> Lens' Game Room
find n = roomMap . singular (ix n)
enterRoom :: String -> GameState
enterRoom n = do
 r <- use $ find n
 v <- find n . Room.visited <<.= True
 currentRoom .= r
 return $ r ^. if v then Room.name else Room.nameWithDescription

Note that currentRoom is the version of r that does not have its visited set to True yet. This could have been averted if currentRoom merely contained the room's name.

The recommendation to use abstractions theoretically also goes for travel, but what's needed here isn't available in the common libraries. Using my package prototype pointed-alternative and missing StateT combinator getsT:

travel :: Direction -> GameState
travel d = ascertain "You can't go that way."
 $ Game.enterRoom
 =<< getsT (Room.roomInDirection d . Game.currentRoom)