haskell ConsoleResource

ConsoleResource.hs

module Resources.Console where

import Resources.Resource
import Misere.Game

newtype ConsoleResource a = ConsoleResource ([Move] -> IO ([Move], a))

instance Resource ConsoleResource where
    putNewState move = ConsoleResource $ \prevState -> return (move:prevState, ())

    --getCurrentState :: ConsoleResource ([Move] -> IO ([Move], [Move]))
    getCurrentState = ConsoleResource $ \prevState -> do
        putStrLn "Make yer move: "
        line <- getLine
        case reads line :: [(Int, String)] of
            [(x, afterX)] ->
                case reads afterX :: [(Int, String)] of
                    [(y, _)] -> do
                        let coords = (x, y)
                        let mv = Move coords X "ABC"
                        let newState = mv:prevState
                        putStrLn $ showBoard newState
                        return (newState, newState)
                        --putStrLn $ "You chose " ++ show coords
                    _ -> do
                        putStrLn "Invalid second number"
                        unwrap getCurrentState prevState
            _ -> do
                putStrLn "Invalid first number"
                unwrap getCurrentState prevState
        where
            unwrap (ConsoleResource x) = x


instance Applicative ConsoleResource where
    pure = return
    f <*> x = f >>= (\f -> x >>= \x -> return (f x))

instance Functor ConsoleResource where
    fmap f x = pure f <*> x

instance Monad ConsoleResource where
    return val = ConsoleResource (\_ -> return $ return val)
    x >>= f = ConsoleResource (\prevState -> do
        value <- unwrap x prevState
        -- x :: ConsoleResource ([Move] -> IO ([Move, a]))
        -- unwrap x :: [Move] -> IO ([Move], a)
        -- unwrap x prevState :: IO ([Move], a)
        -- value :: ([Move], a)
        -- f :: a -> IO b

        unwrap  (f (snd value)) (fst value) -- but why?
        )
        where
            unwrap (ConsoleResource x) = x
            
showBoard :: [Move] -> String
showBoard moves = 
    let subBoard = 
    --join (map (\l -> join l " ") (
            map 
            (map (cellState moves))
            [ [(0,0), (0,1), (0,2)]
            , [(1,0), (1,1), (1,2)]
            , [(2,0), (2,1), (2,2)]
            ]
    --    )) "\n"
    in
        join (map (\l -> join l " | ") subBoard) "\n---------\n"
    where
        cellState :: [Move] -> (Int, Int) -> String
        cellState moves c = 
            case filter (\m -> coords m == c) moves of
                [] -> " "
                (x:_) -> show (piece x)

join :: [String] -> String -> String
join [] _ = ""
join [x] _ = x
join (x:xs) sep = x ++ sep ++ join xs sep

runConsole :: [Move] -> ConsoleResource a -> IO ([Move], a)
runConsole moves console = unconsole console moves
        where unconsole (ConsoleResource x) = x