Weird TicTacToe

TicTacToe.hs

module TicTacToe where

import Control.Applicative
import Control.Monad
import Data.Semigroup hiding (First)
import Data.Monoid hiding ((<>))

data Three = One | Two | Three deriving (Show, Eq)
newtype Tic a = Tic { unTic :: Three -> Three -> Maybe a } 

instance Semigroup (Tic a) where
    (<>) (Tic f) (Tic g) = Tic $ \x y -> 
        case f x y of
            Just z -> Just z
            Nothing -> 
                case g x y of
                    Just z -> Just z
                    Nothing -> Nothing
                    
instance Monoid (Tic a) where
    mempty = Tic $ \x y -> Nothing
    mappend = (<>)

instance Functor Tic where
    fmap f tic = Tic $ \x y -> f <$> unTic tic x y

instance Applicative Tic where
    pure a = Tic $ \x y -> Just a -- Nothing works too, not sure the implication
    (<*>) tf ta = Tic $ \x y -> unTic tf x y <*> unTic ta x y

-- Not totally sure this is correct:
instance Alternative Tic where
    empty = mempty
    (<|>) = mappend

instance Monad Tic where
    return = pure
    (>>=) (Tic g) f = 
        Tic $ \x y -> do
            (Tic h) <- f <$> g x y
            h x y

move0 :: Tic String
move0 = Tic $ \x y -> Nothing

move1 :: Tic String
move1 = Tic $ \x y -> if x == Two && y == Two then Just "x" else Nothing

move2 :: Tic String
move2 = Tic $ \x y -> if x == Three && y == Three then Just "o" else Nothing

move3 :: Tic String
move3 = Tic $ \x y -> if x == Two && y == Three then Just "x" else Nothing

currentBoard :: Tic String
currentBoard = move0 <> move1 <> move2 <> move3

-- Nothing == an empty square:
-- *TicTacToe> unTic currentBoard Three Three
-- Just "o"
-- *TicTacToe> unTic currentBoard Two Two
-- Just "x"
-- *TicTacToe> unTic currentBoard Two One
-- Nothing

-- Helper Functions to generate new board positions:
genMove :: Three -> Three -> a -> Tic a
genMove x y a = Tic $ \x' y' -> if x == x' && y == y' then Just a else Nothing

addMove :: Three -> Three -> a -> Tic a -> Either String (Tic a)
addMove x y a (Tic f) = 
    case f x y of
        Just _ -> Left "That square is occupied"
        Nothing -> 
            Right $ genMove x y a <> Tic f


-- This is neat and weird but kinda useless.
-- Concats the two `a`s if tic == tac:
f :: Tic String -> Tic String -> Tic String
f tic tac = do
    tic' <- tic 
    tac' <- tac
    return $  tic' ++ tac'