Toying around Freer monad with Tic-Tac-Toe

Tictactoe_Freer_monad.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TypeOperators #-}

module Main where

import System.Console.ANSI
import System.Random
import Data.List
import Data.String
import Control.Natural (type (~>))
import Control.Monad.Freer
  (
    Eff
  , LastMember
  , Member
  , interpret
  , interpretM
  , send
  , run
  , runM
  )

initState = ["0", "1", "2", "3", "4", "5", "6", "7", "8" ]
winners = [[0,1,2], [3,4,5], [6,7,8],[0,3,6], [1,4,7], [2,5,8],[0,4,8], [2,4,6] ]

makeBoardString :: [String]->String
makeBoardString myBoard = res
  where
   empty = "   " ; vLine = "  |  " ;  hLine = "\n-------------------\n"
   rows = map (\x->empty ++ ( intercalate vLine $  take 3 $ drop x myBoard)) [0,3,6]
   res = (rows !!0) ++ hLine ++ (rows !!1) ++ hLine ++ (rows !!2) ++ "\n\n"

changeListElemByIndex::[String]->String->Int->[String]
changeListElemByIndex lst stVal index = take index lst ++ [stVal] ++ drop (index + 1) lst

machineTurn ::[String] -> IO Int
machineTurn myBoard = do
   let leng = length $ filter (\q-> q /= "X" && q /= "@") myBoard
   let zipped = filter (\(p,q) -> q /= "X" && q /= "@") $ zip [0..] myBoard
   if leng == 1 then return (fst $ zipped !! 0)
   else do
    randomIndex <- randomRIO (0, (length zipped)-1):: IO Int
    let boardElemIndex = fst $ zipped !! randomIndex
    if (myBoard!! 4 /="X" &&(myBoard!! 4 /="@")) then return 4 else return boardElemIndex

makeHumanTurn::[String] -> IO ([String],Int)
makeHumanTurn myBoard = do
           putStrLn "Your turn"
           myTurnPos <- getLine
           let intPos = read myTurnPos :: Int
           let vStr = changeListElemByIndex myBoard "X" intPos
           return (vStr,intPos)

makeMachineTurn::[String] -> IO [String]
makeMachineTurn myBoard = do
            intPos <- machineTurn myBoard
            let vStr = changeListElemByIndex myBoard "@" intPos
            return vStr

isGameEnd :: [String] -> Bool
isGameEnd strArr = flag
    where
     allTheSame xs = all (== head xs) (tail xs)
     isMyLineFilled= \iArr strArr  -> allTheSame (map (\x->strArr !! x) ( map (\d-> iArr !! d ) [0..2]))
     filledLinesList = filter (\xc-> xc == True) (map (\x -> isMyLineFilled x strArr ) winners)
     flag = if (length filledLinesList == 0) then True else False

firstCleanThenShow :: String -> IO()
firstCleanThenShow str = do
        clearScreen
        setCursorPosition 0 0
        putStrLn str

data Console r where
  ShowMyBoard :: String -> Console ()
  WriteLine :: String -> Console ()
  HumanTurn :: [String] -> Console ([String],Int)
  PcTurn :: [String] -> Console [String]

humanTurn :: Member Console effs => [String]->  Eff effs ([String],Int)
humanTurn srr = send $ HumanTurn srr

pcTurn ::Member Console effs => [String]->  Eff effs [String]
pcTurn srr = send $ PcTurn srr

writeLine :: Member Console effs => String -> Eff effs ()
writeLine string = send $ WriteLine string

showMyBoard :: Member Console effs => String -> Eff effs ()
showMyBoard string = send $ ShowMyBoard string

interpretIO ::
     (LastMember IO effs, Member IO effs) => Eff (Console ': effs) ~> Eff effs
interpretIO =
  interpretM
    (\case
       WriteLine msg -> putStrLn msg
       ShowMyBoard msg -> firstCleanThenShow msg
       HumanTurn arr -> makeHumanTurn arr
       PcTurn arr -> makeMachineTurn arr
       )

game:: Member Console effs => ([String],Bool) -> Eff effs ()
game (stl,whosTurn) = do
      if (whosTurn==True) then do
             vStr <- pcTurn stl
             showMyBoard $ makeBoardString vStr
             if (isGameEnd vStr) == False then do
                 writeLine "GAME END PC wins"
                 return ()
             else game (vStr,False)
      else do
        showMyBoard $ makeBoardString stl
        (vStr,intPos) <- humanTurn stl
        if (intPos < 0 || intPos > 8)
            then do
               writeLine "Game has been stopped"
               return ()
        else
         if (isGameEnd vStr) == False then do
              showMyBoard $ makeBoardString vStr
              writeLine "GAME END Human wins"
              return ()
         else do
           showMyBoard $ makeBoardString vStr
           game (vStr,True)

main :: IO ()
main = do
  runM . interpretIO $ game (initState,False)

{-
dependencies:
- base >= 4.7 && < 5
- freer-simple
- natural-transformation
- ansi-terminal
- random

-}