{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}

module Parser (
    ReadError (..),
    readDiffFiles,
    readDeckList,
    fromByteString,
    fromText,
    evalDiffs,
) where

import Control.Applicative
import Control.Arrow
import Control.Concurrent.Async
import Control.Monad

import Control.Monad.State

import Data.Either.Extra
import Data.Functor
import Data.List.Extra
import Data.Map (Map)

import Data.ByteString (ByteString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8')
import qualified Data.Text.IO as TIO

import Data.Attoparsec.Text

import Refined hiding (validate)
import Refined.Unsafe

import Deck.Category
import Deck.Deck
import Deck.Diff
import Repr.Interpret
import Repr.StateRep

data ReadError
    = IllegalFormat
    | ParseFailure Text
    | RefineError !RefineException
    deriving (Show)

type RecordParser = StateT CategoryName Parser

data Record = Record
    { recordName :: CardName
    , recordCopies :: PositiveNumber
    , recordCategory :: CategoryName
    }
    deriving (Show)

cardNameP :: Parser CardName
cardNameP = do
    ch <- anyChar
    remaining <- T.pack <$> manyTill anyChar (endOfLine <|> endOfInput)
    return . NonEmptyText . reallyUnsafeRefine $ T.cons ch remaining

copiesP :: Parser Copies
copiesP = do
    num <- decimal
    if num == 0
        then fail "not a positive number"
        else return . PositiveNumber . reallyUnsafeRefine $ num

recordP :: CategoryName -> Parser Record
recordP recordCategory = do
    recordCopies <- copiesP
    void $ optional $ char 'x'
    skipSpace
    recordName <- cardNameP
    return $ Record {recordName, recordCopies, recordCategory}

decklistP :: RecordParser [Record]
decklistP = do
    mb <- lift $ manyTill (recordP mainboard) (endOfLine <|> endOfInput)
    lift skipSpace

    sb <- lift $ manyTill (recordP sideboard) (endOfLine <|> endOfInput)
    return $ mb ++ sb

fromByteString ::
    (DeckSYM repr) => ByteString -> Either [ReadError] [DiffSig repr]
fromByteString content = do
    res <- mapLeft (const [IllegalFormat]) $ decodeUtf8' content
    fromText res

fromText :: (DeckSYM repr) => Text -> Either [ReadError] [DiffSig repr]
fromText content =
    let parsed =
            mapLeft (singleton . ParseFailure . T.pack) . flip parseOnly content $
                (evalStateT decklistP mainboard <* endOfInput)
     in map (\Record {..} -> add recordName recordCategory recordCopies) <$> parsed

evalDiffs :: [DiffSig R] -> [DiffSig R] -> (Map Text Card, Map Text Card)
evalDiffs =
    let f = eval . evalMany
     in curry (f *** f)

readDeckList ::
    (DeckSYM repr) =>
    FilePath
    -> IO (Either [ReadError] [DiffSig repr])
readDeckList p = TIO.readFile p <&> fromText

readDiffFiles ::
    FilePath -> FilePath -> IO (Either [ReadError] (Map Text Card, Map Text Card))
readDiffFiles oldFile newFile = do
    oldTask <- async (fmap (eval . evalMany) <$> readDeckList oldFile)
    newTask <- async (fmap (eval . evalMany) <$> readDeckList newFile)

    finished <- waitEither oldTask newTask

    case finished of
        Left (Left e) -> cancel newTask >> pure (Left e)
        Right (Left e) -> cancel oldTask >> pure (Left e)
        Left (Right x) -> do
            y <- wait newTask
            case y of
                Left e -> pure $ Left e
                Right n -> pure . Right $ (x, n)
        Right (Right x) -> do
            y <- wait oldTask
            case y of
                Left e -> pure $ Left e
                Right n -> pure . Right $ (n, x)