{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module StateRep (
    RDefault,
    CardMap,
    R,
    eval,
    evalMany,
) where
import Control.Monad.State
import Data.Foldable
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import Refined
import Deck
import Diff
type CardMap = Map Text Card
type RDefault = R (State CardMap)
newtype R m a = R {unR :: m a} deriving (Functor, Applicative, Monad)
instance DeckSYM (R (State CardMap)) where
    add x = R $ do
        deck <- get
        put $ Map.insert (unrefine . runText $ name x) x deck
    remove cardName = R $ do
        deck <- get
        put $ Map.delete (unrefine . runText $ cardName) deck
instance HunkSYM (R (State CardMap)) where
    lookup x = R $ do
        deck <- get
        cardName <- unR x
        return $ Map.lookup cardName deck
    chunk oldCardName f = R $ do
        cardFunction <- unR . sequence $ f
        decklist <- get
        case Map.lookup (unrefine . runText $ oldCardName) decklist of
            Nothing -> return ()
            Just oldCard ->
                let newCard = foldl' (\acc cardUpd -> cardUpd acc) oldCard cardFunction
                 in put $
                        Map.update (const $ Just newCard) (unrefine . runText $ oldCardName) decklist
    modifyCopies newCopies = do
        return $ \oldCard -> do
            let newQuantity = newCopies . quantity $ oldCard
            oldCard {quantity = newQuantity}
    modifyCategory categoryF = do
        return $ \oldCard -> do
            let newCategory = categoryF . Deck.category $ oldCard
            oldCard {Deck.category = newCategory}
    move x = const <$> x
eval :: R (State CardMap) a -> CardMap
eval = flip execState mempty . unR
evalMany :: (Traversable t) => t (RDefault ()) -> CardMap
evalMany x = flip execState mempty $ mapM unR x

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Parser (
    ReadError (..),
    readCard,
    readDeckList,
) where
import Control.Arrow
import Data.Bifunctor
import Data.Either.Extra
import Data.List.Extra
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Text.Read (readMaybe)
import GHC.Natural
import Refined hiding (validate)
import Deck
import Diff
data ReadError = IllegalFormat | RefineError !RefineException deriving (Show)
readCard :: Category -> Text -> Either [ReadError] Card
readCard c n =
    let toError (l, r) = case l of
            Nothing -> Left $ singleton IllegalFormat
            Just x -> Right (x, r)
        refined :: (Predicate p a) => a -> Either ReadError (Refined p a)
        refined = mapLeft RefineError . refine
        validate =
            arr (fmap PositiveNumber . refined) *** arr (fmap NonEmptyText . refined)
                >>> arr
                    ( \case
                        (Right x, Right y) -> Right (x, y)
                        (Left x, Left y) -> Left [x, y]
                        (Left x, _) -> Left $ singleton x
                        (_, Left x) -> Left $ singleton x
                    )
        toCard tup = (\(x, y) -> Card y x c) <$> validate tup
     in (toError . bimap (readMaybe @Natural) T.pack . word1 . T.unpack $ n)
            >>= toCard
readDeckList :: (DeckSYM repr) => FilePath -> IO (Either [ReadError] [repr ()])
readDeckList p = do
    content <- windowsToLinuxNewLine <$> TIO.readFile p
    let (mb, sb) = T.breakOn "\n\n" content
        mb' = mapM (readCard mainboard) (T.lines mb)
        sb' = mapM (readCard sideboard) (T.lines . T.stripStart $ sb)
    return $ fmap add <$> liftA2 (++) mb' sb'
  where
    windowsToLinuxNewLine = T.replace "\r\n" "\n"

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Diff (
    HunkSYM (..),
    DeckSYM (..),
    diff,
) where
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import Refined
import Deck
class DeckSYM repr where
    -- | Add a card to the deck
    add :: Card -> repr ()
    -- | Remove a card from the deck
    remove :: CardName -> repr ()
class HunkSYM repr where
    -- | A diff chunk for a card
    chunk :: (Traversable t) => CardName -> t (repr (Card -> Card)) -> repr ()
    modifyCopies :: (PositiveNumber -> PositiveNumber) -> repr (Card -> Card)
    modifyCategory :: (Category -> Category) -> repr (Card -> Card)
    -- | Lookup a card in the deck
    lookup :: repr Text -> repr (Maybe Card)
    -- | Move a card to another category
    move :: repr Category -> repr (Category -> Category)
diff :: (HunkSYM repr, DeckSYM repr) => DeckList -> DeckList -> [repr ()]
diff left right =
    let deckSort = map snd . Map.toDescList . runDeckList
     in go mempty (deckSort left) (deckSort right)
  where
    go :: (HunkSYM repr, DeckSYM repr) => [repr ()] -> [Card] -> [Card] -> [repr ()]
    go acc [] [] = acc
    go acc xs [] = acc ++ map (remove . name) xs
    go acc [] ys = acc ++ map add ys
    go acc lx@(x : xs) ly@(y : ys)
        | name x < name y = go (remove (name x) : acc) xs ly
        | name x > name y = go (add x : acc) lx ys
        | otherwise =
            case (partialEqCard quantity x y, partialEqCard category x y) of
                (True, True) -> go acc xs ys
                (False, False) -> go (chunk (name x) [modifyCopies (const $ quantity y), modifyCategory (const . category $ y)] : acc) xs ys
                (False, _) -> go (chunk (name x) [] : acc) xs ys
                (_, False) -> go (chunk (name x) [] : acc) xs ys

{- | Applies a diff to a decklist. If a card doesn't exist during a change in copies it is ignored.
| This is ignored because we don't have a concept of default category.
-}
-- applyDiff :: DeckDiff -> DeckList -> DeckList
-- applyDiff [] ys = ys
-- applyDiff (x : xs) decklist =
--     case x of
--         Add a -> applyDiff xs (insert a decklist)
--         Remove a -> delete a decklist
--         ChangeCard name newQuan newCat ->
--             let newQuantity = newQuan . quantity <$> card 
--                 newCategory = card <$> newCat
--                 cardQuantity = fromIntegral . unrefine . runNumber . quantity
--                 card = Deck.find name decklist
--                 -- choice =
--                 --     either
--                 --         (const $ applyDiff (Remove name : xs) decklist)
--                 --         (\quantity -> update (\(x', _) -> (x', PositiveNumber quantity)) name decklist)
--                 -- choiceFind =
--                 --     maybe
--                 --         decklist
--                 --         (choice . refine . fromIntegral . newQuantity . cardQuantity)
--              in choiceFind card

-- modifyCard :: (Card -> Card) -> CardName -> DeckList -> DeckList
-- modifyCard = error "not implemented"

initDeckList :: IO DeckList
initDeckList = do
    gen <- createSystemRandom
    nid <- nanoID gen
    return . DeckList . Set.fromList $ []

-- initDeckList :: IO DeckList
-- initDeckList = do
--     gen <- createSystemRandom
--     nid <- nanoID gen
--     return . DeckList . Set.fromList $ []

        comonad,
        mtl,