{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}

module Main where

import           Protolude            hiding (get, put)

import           Control.Monad.Except (ExceptT, liftEither, runExceptT,
                                       throwError)
import           Control.Monad.State  (StateT, get, put, runStateT)

import           Data.HashMap.Strict  as HMS (HashMap, empty, insert, lookup)
import           Data.IORef           (IORef, atomicModifyIORef, newIORef,
                                       readIORef)
import           Data.List.Split
import           Data.Text            (Text, lines, pack, unpack)

import           Safe                 (headMay, readMay)
import           System.Random        (randomIO)

import           Error
import           Game                 (GameState, Player (..), getBoard,
                                       getMoves, getRandomShipsIO, getShips,
                                       getWinner, makeMove, mkGameState,
                                       setShips)
import           Yesod                hiding (get)

setupShips :: Monad m => GameState -> [((Char, Int), Bool)] -> [((Char, Int), Bool)]
           -> ExceptT GameError m GameState
setupShips s s1 s2 = do
  s' <- liftEither $ setShips s Player1 s1
  liftEither $ setShips s' Player2 s2

setupRandomShipsIO :: GameState -> ExceptT GameError IO GameState
setupRandomShipsIO s = do
  ms1 <- liftIO getRandomShipsIO
  ms2 <- liftIO getRandomShipsIO
  let mships = (,) <$> ms1 <*> ms2
  case mships of
    Just (s1, s2) -> setupShips s s1 s2
    Nothing -> throwError $ GameErrorIllegalPlacement "random ship generation failed"

newtype App = App{
  gameStates :: IORef (HashMap Int GameState)
}

mkYesod "App" [parseRoutes|
/          HomeR      GET
/StartGame StartGameR POST
/MakeMove  MakeMoveR  POST
|]

instance Yesod App

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

newtype Game = Game
    { gameNoRes :: Int
    }
    deriving Show

updState :: Int -> GameState -> IORef (HashMap Int GameState) -> IO (HashMap Int GameState)
updState k st gs = atomicModifyIORef gs (\hm -> (HMS.insert k st hm, hm))

startForm :: Html -> MForm Handler (FormResult Game, Widget)
startForm extra = do
    (gr, _gameNV) <- mreq intField "neither is this" (Just 0)
    let gameRes = Game <$> gr
    let widget = do
          toWidget [lucius|
            body{font-size:200%;font-family:sans-serif}
            .button{font-size:200%;font-family:sans-serif}
          |]
          [whamlet|
              #{extra}
              Thar be storm seas and ye have just spied the navy.<br>
              Your ships be showing where ya ships be and the navy '.'-misses and '*'-hits.<br>
              Click on the squard to fire ya cannons!<br>
              The enemy will fire after your turn.<br><br>

              Thar be feature gaps:<br>
              The navy tends to copy your cannon shots<br>
              Your ships are where the are - ya cannot place them with your pirate cunning.<br>
              Graphics could use `some` work.<br>
              Arrrr...<br>
              <p>
                <input type=submit class="button" name="action" value="New Game"><br><br>
          |]
    return (gameRes, widget)

getHomeR :: Handler Html
getHomeR = do
    ((_res, widget), enctype) <- runFormPost startForm
    --action <- lookupGetParam "action"
    defaultLayout
        [whamlet|
            <form method=post action=@{StartGameR} type=#{enctype}>
                ^{widget}
        |]

showInt :: Int -> Text
showInt = show

renderShipLayout :: GameState -> HandlerFor App Html
renderShipLayout st = defaultLayout $ do
  let board = getBoard (getShips st Player2) (getMoves st Player1 ) False
  let ls = lines $ pack board
  let rows = zip ['a'..'j'] <$> map unpack ls
  let coordRows = zip [1..10] rows
  toWidget [lucius|
    body{font-size:200%;font-family:sans-serif}
    .button{font-size:300%;font-family:monospace}
    .table {
        display: table;
        width: auto;
        margin: 2px;
        background-color: lightblue;
        border: 1px solid #666666;
        /* border-spacing:5px;/*cellspacing:poor IE support forthis*/
        border-collapse: separate;
    }

    .table-cell {
        float: left;
        background-color: blue;
        margin: 2px;
    }
    table {
        table-layout: fixed;
    }
  |]
  [whamlet|
    Ya brave pirate ships:
    <pre>
      #{ getBoard (getShips st Player1) (getMoves st Player2 ) True}<br>
    <pre>
      Cannon shots:
      <form method=post action=@{MakeMoveR}>
        <div class="table">
          $forall (rowId, row) <- coordRows
            <div class="table-row">
            $forall (colId, val) <- row
              <div class="table-cell">
                <button class=button type=submit name=move value="#{colId},#{showInt rowId}">#{val}
|]

gameErrorLayout :: Text -> HandlerFor App Html
gameErrorLayout s = defaultLayout $ do
    toWidget [lucius|
      body{font-size:200%;font-family:sans-serif}
      .button{font-size:200%;font-family:sans-serif}
    |]
    [whamlet|
    <p>Error: #{s}
    <form method=get action=@{HomeR}>
      <input type=submit class="button" name="action" value="New Game">
    |]

gameEndedLayout :: Text -> HandlerFor App Html
gameEndedLayout s = defaultLayout $ do
    toWidget [lucius|
      body{font-size:200%;font-family:sans-serif}
      .button{font-size:200%;font-family:sans-serif}
    |]
    [whamlet|
    <p>#{s} <br>
    <form method=get action=@{HomeR}>
      <input type=submit class="button" name="action" value="New Game">
    |]

postStartGameR :: Handler Html
postStartGameR = do
    --((res, widget), enctype) <- runFormPost personForm
    yesod <- getYesod
    -- action <- lookupPostParam "action"
    -- liftIO $ putStrLn $ show action
    x <- liftIO $ runExceptT $ setupRandomShipsIO mkGameState
    case x of
      Right st -> do
        liftIO $ putStrLn $ getBoard (getShips st Player2) (getMoves st Player1 ) True
        session <- liftIO randomIO
        setSession "gameId" (pack $ show session)
        _ <- liftIO $ updState session st $ gameStates yesod
        renderShipLayout st
      Left y -> gameErrorLayout (pack $ show y)

getColRow :: Maybe Text -> Maybe (Char, Int)
getColRow move =
  case move of
    Just m ->
      let s = splitOn "," $ unpack m
          mcs = headMay s
          mrs = s `atMay` 1 in
      case (mcs, mrs) of
        (Just cs, Just rs) -> (,) <$> headMay cs <*> readMay rs
        _                  -> Nothing
    _ -> Nothing

getSesh :: Maybe Text -> Int
getSesh t = case t of
    Just v  -> fromMaybe 0 $ readMay (unpack v)
    Nothing -> 0

moveModifyState ::  Monad m => (Player, Char, Int)
                -> ExceptT GameError (StateT GameState m) GameState
moveModifyState (player, r, c) = do
 st <- get
 st' <- liftEither $ makeMove st player r c
 put st'
 return st'

-- | Submits the moves updating the state, running in EitherT/StateT returns
-- | on Left or list end ()
playMoves_ :: [(Player, Char, Int)]
         -> ExceptT GameError (StateT GameState IO) ()
playMoves_ = mapM_ moveModifyState

postMakeMoveR :: Handler Html
postMakeMoveR = do
  yesod <- getYesod
  gs <- liftIO $ readIORef $ gameStates yesod
  move <- lookupPostParam "move"
  let mcr = getColRow move
  ses <-  lookupSession "gameId"
  let session = getSesh ses
  let oGSt = HMS.lookup session gs
  case (oGSt, mcr) of
    (Just st, Just colRow) -> do
      (eSt, st') <- liftIO $ flip runStateT st . runExceptT $ playMoves_
                    [ (Player1, fst colRow, snd colRow)
                    , (Player2, fst colRow, snd colRow) ]
      case getWinner st' of
        Just Player1 -> gameEndedLayout "You won! :-)"
        Just Player2 -> gameEndedLayout "You lost :-("
        Nothing -> case eSt of
            Right _ -> do
                _ <- liftIO $ updState session st' $ gameStates yesod
                renderShipLayout st'
            Left err -> gameErrorLayout (pack $ show err)
    _ -> gameErrorLayout "Could not retrieve state"

main :: IO ()
main = do
  hm <- newIORef HMS.empty
  warp 3000 (App hm)
