{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
# LANGUAGE LambdaCase #
# LANGUAGE DataKinds #

module Magic.Json (interactToJSON) where

import Magic
import Magic.Engine.Types
import qualified Magic.IdList as IdList

import Control.Applicative ((<$>))
import Control.Monad (mzero, (>=>))

import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), (.=), decode)
import Data.Aeson.Types (Pair, Parser, parse, (.:))
import qualified Data.Aeson as Aeson
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Char (toLower)
import Data.Scientific (coefficient, base10Exponent)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Traversable (for)
import qualified Data.Vector as Vector
import Debug.Trace (trace)

import Safe (atMay)



obj :: [Pair] -> Value
obj = Aeson.object

withIntegral :: Integral b => String -> (b -> Parser a) -> Value -> Parser a
withIntegral s k = Aeson.withScientific s $ \number ->
  case base10Exponent number of
    0 -> k (fromInteger (coefficient number))
    _ -> undefined

typedObject :: (Text, [Pair]) -> Value
typedObject (typeName, props) = obj ("type" .= String typeName : props)

class ToJSONPairs a where
  toJSONPairs :: a -> [Pair]



instance ToJSON IdList.Id where
  toJSON = toJSON . IdList.idToInt

instance FromJSON IdList.Id where
  parseJSON = withIntegral "Id" $ return . IdList.Id

instance ToJSON a => ToJSON (IdList.IdList a) where
  toJSON list = obj ( "order" .= IdList.ids list
                    : map (\(i,x) -> Text.pack (show i) .= toJSON x) (IdList.toList list)
                    )



someObjectRefToJSON :: SomeObjectRef -> Value
someObjectRefToJSON (Some z, i) = obj [ "zone" .= z, "objectId" .= i ]

  TODO use withObject
someObjectRefFromJSON :: Aeson.Object -> Parser SomeObjectRef
someObjectRefFromJSON v = do
  z <- v .: "zone"
  z' <- someZoneRefFromJSON z
  o <- v .: "objectId"
  return (z', IdList.Id o)

objectRefToJSON :: ObjectRef ty -> Value
objectRefToJSON (z, i) = obj [ "zone" .= z, "objectId" .= i ]

activatedAbilityRefToJSON :: ActivatedAbilityRef -> Value
activatedAbilityRefToJSON (r, i) =
  obj [ "objectRef" .= someObjectRefToJSON r, "index" .= i ]

instance ToJSON (ZoneRef ty) where
  toJSON z = case z of
    Library p   -> obj [ "name" .= String "library", "playerId" .= p ]
    Hand p      -> obj [ "name" .= String "hand", "playerId" .= p ]
    Battlefield -> obj [ "name" .= String "battlefield" ]
    Graveyard p -> obj [ "name" .= String "graveyard", "playerId" .= p ]
    Stack       -> obj [ "name" .= String "stack" ]
    Exile       -> obj [ "name" .= String "exile" ]
    Command     -> obj [ "name" .= String "command" ]

someZoneRefToJSON :: Some ZoneRef -> Value
someZoneRefToJSON (Some z) = toJSON z

  TODO use withObject
someZoneRefFromJSON :: Aeson.Object -> Parser (Some ZoneRef)
someZoneRefFromJSON v = do
  n <- v .: "name" :: Parser Text
  case n of
    "library"     -> do 
                     p <- v .: "playerId"
                     return (Some (Library (IdList.Id p)))
    "hand"        -> do
                     p <- v .: "playerId" 
                     return (Some (Hand (IdList.Id p)))
    "battlefield" -> return (Some Battlefield)

lkiToJSON :: LastKnownObjectInfo -> Value
lkiToJSON (r, o) = obj [ "objectRef" .= someObjectRefToJSON r, "object" .= obj (toJSONPairs o) ]


instance ToJSON World where
  toJSON w = obj
    [ "players"        .= _players w
    , "activePlayerId" .= _activePlayer w
    , "activeStep"     .= _activeStep w
    , "time"           .= _time w
    , "exile"          .= _exile w
    , "battlefield"    .= _battlefield w
    , "stack"          .= _stack w
    , "command"        .= _command w
    ]



instance ToJSON Step where
  toJSON phase = obj $ case phase of
    BeginningPhase step -> ("phase" .= String "beginning") : toJSONPairs step
    MainPhase ->           ("phase" .= String "main")      : []
    CombatPhase step ->    ("phase" .= String "combat")    : toJSONPairs step
    EndPhase step ->       ("phase" .= String "end")       : toJSONPairs step

instance ToJSONPairs BeginningStep where
  toJSONPairs step = ["step" .= String value]
    where
      value = case step of
        UntapStep  -> "untap"
        UpkeepStep -> "upkeep"
        DrawStep   -> "draw"

instance ToJSONPairs CombatStep where
  toJSONPairs step = ["step" .= String value]
    where
      value = case step of
        BeginningOfCombatStep -> "beginningOfCombat"
        DeclareAttackersStep  -> "declareAttackers"
        DeclareBlockersStep   -> "declareBlockers"
        CombatDamageStep      -> "combatDamage"
        EndOfCombatStep       -> "endOfCombat"

instance ToJSONPairs EndStep where
  toJSONPairs step = ["step" .= String value]
    where
      value = case step of
        EndOfTurnStep -> "endOfTurn"
        CleanupStep   -> "cleanup"



instance ToJSON Player where
  toJSON p = obj
    [ "life"      .= _life p
    , "manaPool"  .= _manaPool p
    , "library"   .= _library p
    , "hand"      .= _hand p
    , "graveyard" .= _graveyard p
    ]



instance ToJSON (ObjectOfType a) where
  toJSON (CardObject o) = obj (toJSONPairs o)
  toJSON p@(Permanent {}) =
      obj (toJSONPairs (_permanentObject p) ++ permProps)
    where
      permProps = [ "tapStatus" .= _tapStatus p, "damage"    .= _damage p ]
  toJSON (StackItem o _) = obj (toJSONPairs o)

instance ToJSONPairs Object where
  toJSONPairs o =
    [ "name" .= _name o
    , "colors" .= _colors o
    , "types" .= _types o
    , "ownerId" .= _owner o
    , "controllerId" .= _controller o
    , "timestamp" .= _timestamp o
    , "counters" .= _counters o
    , "pt" .= maybe Null (\(p,t) -> obj [ "power" .= p, "toughness" .= t ]) (_pt o)
    , "staticKeywordAbilities" .= _staticKeywordAbilities o
    ]



instance ToJSON Color where
  toJSON = toJSON . map toLower . show

instance ToJSON TapStatus where
  toJSON = toJSON . map toLower . show

instance ToJSON CounterType where
  toJSON = toJSON . map toLower . show



instance ToJSON ObjectTypes where
  toJSON tys = obj
    [ "supertypes"        .= supertypes tys
    , "artifactTypes"     .= artifactSubtypes tys
    , "creatureTypes"     .= creatureSubtypes tys
    , "enchantmentTypes"  .= enchantmentSubtypes tys
    , "instantTypes"      .= instantSubtypes tys
    , "landTypes"         .= landSubtypes tys
    , "planeswalkerTypes" .= planeswalkerSubtypes tys
    ]

instance ToJSON Supertype           where toJSON = toJSON . show
instance ToJSON ArtifactSubtype     where toJSON = toJSON . show
instance ToJSON CreatureSubtype     where toJSON = toJSON . show
instance ToJSON EnchantmentSubtype  where toJSON = toJSON . show
instance ToJSON SpellSubtype        where toJSON = toJSON . show
instance ToJSON LandSubtype         where toJSON = toJSON . show
instance ToJSON PlaneswalkerSubtype where toJSON = toJSON . show


instance ToJSON StaticKeywordAbility where
  toJSON = \case
    FirstStrike -> "first strike"
    ProtectionFromColor c ->
      toJSON ("protection from " ++ map toLower (show c))
    ab -> (toJSON . map toLower . show) ab

instance ToJSON PriorityAction where
  toJSON a = typedObject $ case a of
    PlayCard r        -> ("playCard", [ "objectRef" .= objectRefToJSON r ])
    ActivateAbility r -> ("activateAbility", [ "activatedAbilityRef" .= activatedAbilityRefToJSON r ])

instance ToJSON PayManaAction where
  toJSON a = typedObject $ case a of
    PayManaFromManaPool mc ->
      ("payManaFromManaPool", [ "color" .= mc ])
    ActivateManaAbility r ->
      ("activateManaAbility", [ "activatedAbilityRef" .= activatedAbilityRefToJSON r])




instance ToJSON Event where
  toJSON event = typedObject $ case event of
    Did (GainLife p n)         -> ("gainLife",
      ["playerId" .= p, "amount" .= n])
    Did (LoseLife p n)         -> ("loseLife",
      ["playerId" .= p, "amount" .= n])
    Did (DamageObject _ (Battlefield, i) n c p) -> ("damageObject",
      [ "objectId" .= i, "amount" .= n, "isCombatDamage" .= c ])
    Did (DamagePlayer _ r n c p) -> ("damagePlayer",
      [ "playerId" .= r, "amount" .= n, "isCombatDamage" .= c ])
    Did (ShuffleLibrary p)       -> ("shuffleLibrary", [ "playerId" .= p ])
    Did (DrawCard p)             -> ("drawCard", [ "playerId" .= p ])
    Did (DestroyPermanent (Battlefield, i) _)   -> ("destroyPermanent", [ "objectId" .= i ])
    Did (TapPermanent (Battlefield, i)) -> ("tapPermanent", [ "objectId" .= i ])
    Did (UntapPermanent (Battlefield, i)) -> ("untapPermanent", [ "objectId" .= i ])
    Did (AddToManaPool p m)      -> ("addToManaPool",
      [ "playerId" .= p, "mana" .= m ])
    Did (SpendFromManaPool p m)  -> ("spendFromManaPool",
      [ "playerId" .= p, "mana" .= m ])
    Did (PlayLand p r)           -> ("playLand",
      [ "playerId" .= p, "objectRef" .= someObjectRefToJSON r ])
    Did (LoseGame p)             -> ("loseGame", [ "playerId" .= p ])
    Did (WinGame p)              -> ("winGame", [ "playerId" .= p ])
    Did (CeaseToExist r)         -> ("ceaseToExist",
      [ "objectRef" .= someObjectRefToJSON r ])
    DidMoveObject mOldRef newRef -> ("moveObject",
      [ "oldRef" .= maybe Null someObjectRefToJSON mOldRef
      , "newRef" .= someObjectRefToJSON newRef ])
    DidDeclareAttackers p ats      -> ("declareAttackers",
      [ "playerId" .= p, "attacks" .= ats ])
    DidBeginStep step            -> ("beginStep", [ "step" .= step ])
    WillEndStep step             -> ("willEndStep", [ "step" .= step ])
    _ -> error ("unhandled event: " ++ show event)

instance ToJSON Attack where
  toJSON (Attack atr atee) = obj [ "attacker" .= atr, "attackee" .= atee ]

instance ToJSON GameOver where
  toJSON t = typedObject $ case t of
    GameWin p -> ("gameWin", [ "playerId" .= p ])
    GameDraw -> ("gameDraw", [])
    ErrorWithMessage msg -> ("error", [ "message" .= msg ])

instance ToJSON EntityRef where
  toJSON t = typedObject $ case t of
    PlayerRef p -> ("player", [ "playerId" .= p ])
    ObjectRef r -> ("object", [ "objectRef" .= someObjectRefToJSON r ])

instance FromJSON EntityRef where
  parseJSON = Aeson.withObject "EntityRef" $ \o -> do
    ty <- o .: "type" :: Parser Text
    case ty of
      "player" -> PlayerRef <$> o .: "playerId"
      "object" -> do ObjectRef <$> (o .: "objectRef" >>= someObjectRefFromJSON)
      _ -> mzero

interactToJSON :: Monad m => m ByteString -> Interact a -> (Value, m a)
interactToJSON receiveData op = (typedObject (instrType, props), receiveAnswer)
  where
    (instrType, props, receiveAnswer) = case op of
      Debug msg -> ("debug", [ "message" .= msg ], return ())
      LogEvents _source events world ->
        ("logEvents", [ "events" .= events, "world" .= world ], return ())
      AskQuestion p w q ->
        let (json, select) = questionToJSON q
            getAnswer = do
              input <- receiveData
              case fmap (parse (unwrapAnswer select)) (decode input) of
                Nothing -> do
                  trace ("Invalid JSON input from client: " ++ BS.unpack input) $
sendText ( " Invalid option " : : Text )
                    getAnswer
                Just (Aeson.Error e) ->
                  trace ("Invalid input from client: " ++ BS.unpack input ++ ": " ++ e) $
sendText ( " Invalid option " : : Text )
                    getAnswer
                Just (Aeson.Success x) ->
                  return x
            unwrapAnswer :: (Value -> Parser a) -> Value -> Parser a
            unwrapAnswer k =
              Aeson.withObject "answer object" ((.: "answer") >=> k)
          in ("askQuestion", [ "playerId" .= p, "world" .= w, "question" .= json], getAnswer)

questionToJSON :: Question a -> (Value, Value -> Parser a)
questionToJSON q = (typedObject (questionType, props), select)
  where
    (questionType, props, select) = case q of
      AskKeepHand ->
        ("keepHand", [ ], Aeson.withBool "boolean" return)
      AskPriorityAction opts ->
        ("priorityAction", [ "options" .= (passOption : map toJSON opts) ],
          parseOptionIndex (Nothing : map Just opts))
      AskManaAbility m opts ->
        ("manaAbility", [ "manaToPay" .= m, "options" .= opts ],
          parseOptionIndex opts)
      AskTarget ts ->
        ("target", ["options" .= ts], parseOptionIndex ts)
      AskPickTrigger lkis ->
        ("pickTrigger", ["options" .= map lkiToJSON lkis],
          parseOptionIndex [0..length lkis - 1])
      AskAttackers as ts ->
        ("attack", [ "attackers" .= as, "targets" .= ts ],
          parseAttacks)

    parseOptionIndex :: [a] -> Value -> Parser a
    parseOptionIndex opts =
      withIntegral "option index" $ \i ->
        case atMay opts i of
          Just opt -> return opt
          Nothing  -> fail ("invalid option index: " ++ show i)

    parseAttacks :: Value -> Parser [Attack]
    parseAttacks = parseArray $ Aeson.withObject "object" parseAttack

    parseAttack :: Aeson.Object -> Parser Attack
    parseAttack at = do
      a <- at .: "attacker"
      t <- at .: "attackee" :: Parser EntityRef
      (Some Battlefield, i) <- someObjectRefFromJSON a
      return (Attack (Battlefield, i) t)

    parseArray :: (Value -> Parser a) -> Value -> Parser [a]
    parseArray parseElement = Aeson.withArray "array" $ \vs ->
      for (Vector.toList vs) parseElement

passOption :: Value
passOption = toJSON (typedObject ("pass", []))

# LANGUAGE OverloadedStrings #
# LANGUAGE GADTs #
# LANGUAGE LambdaCase #
# LANGUAGE DataKinds #

module Magic.Json (interactToJSON) where

import Magic
import Magic.Engine.Types
import qualified Magic.IdList as IdList

import Control.Applicative ((<$>))
import Control.Monad (mzero, (>=>))

import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), (.=), decode)
import Data.Aeson.Types (Pair, Parser, parse, (.:))
import qualified Data.Aeson as Aeson
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Char (toLower)
import Data.Scientific (coefficient, base10Exponent)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Traversable (for)
import qualified Data.Vector as Vector
import Debug.Trace (trace)

import Safe (atMay)



obj :: [Pair] -> Value
obj = Aeson.object

withIntegral :: Integral b => String -> (b -> Parser a) -> Value -> Parser a
withIntegral s k = Aeson.withScientific s $ \number ->
  case base10Exponent number of
    0 -> k (fromInteger (coefficient number))
    _ -> undefined

typedObject :: (Text, [Pair]) -> Value
typedObject (typeName, props) = obj ("type" .= String typeName : props)

class ToJSONPairs a where
  toJSONPairs :: a -> [Pair]



instance ToJSON IdList.Id where
  toJSON = toJSON . IdList.idToInt

instance FromJSON IdList.Id where
  parseJSON = withIntegral "Id" $ return . IdList.Id

instance ToJSON a => ToJSON (IdList.IdList a) where
  toJSON list = obj ( "order" .= IdList.ids list
                    : map (\(i,x) -> Text.pack (show i) .= toJSON x) (IdList.toList list)
                    )



someObjectRefToJSON :: SomeObjectRef -> Value
someObjectRefToJSON (Some z, i) = obj [ "zone" .= z, "objectId" .= i ]

  TODO use withObject
someObjectRefFromJSON :: Aeson.Object -> Parser SomeObjectRef
someObjectRefFromJSON v = do
  z <- v .: "zone"
  z' <- someZoneRefFromJSON z
  o <- v .: "objectId"
  return (z', IdList.Id o)

objectRefToJSON :: ObjectRef ty -> Value
objectRefToJSON (z, i) = obj [ "zone" .= z, "objectId" .= i ]

activatedAbilityRefToJSON :: ActivatedAbilityRef -> Value
activatedAbilityRefToJSON (r, i) =
  obj [ "objectRef" .= someObjectRefToJSON r, "index" .= i ]

instance ToJSON (ZoneRef ty) where
  toJSON z = case z of
    Library p   -> obj [ "name" .= String "library", "playerId" .= p ]
    Hand p      -> obj [ "name" .= String "hand", "playerId" .= p ]
    Battlefield -> obj [ "name" .= String "battlefield" ]
    Graveyard p -> obj [ "name" .= String "graveyard", "playerId" .= p ]
    Stack       -> obj [ "name" .= String "stack" ]
    Exile       -> obj [ "name" .= String "exile" ]
    Command     -> obj [ "name" .= String "command" ]

someZoneRefToJSON :: Some ZoneRef -> Value
someZoneRefToJSON (Some z) = toJSON z

  TODO use withObject
someZoneRefFromJSON :: Aeson.Object -> Parser (Some ZoneRef)
someZoneRefFromJSON v = do
  n <- v .: "name" :: Parser Text
  case n of
    "library"     -> do 
                     p <- v .: "playerId"
                     return (Some (Library (IdList.Id p)))
    "hand"        -> do
                     p <- v .: "playerId" 
                     return (Some (Hand (IdList.Id p)))
    "battlefield" -> return (Some Battlefield)

lkiToJSON :: LastKnownObjectInfo -> Value
lkiToJSON (r, o) = obj [ "objectRef" .= someObjectRefToJSON r, "object" .= obj (toJSONPairs o) ]


instance ToJSON World where
  toJSON w = obj
    [ "players"        .= _players w
    , "activePlayerId" .= _activePlayer w
    , "activeStep"     .= _activeStep w
    , "time"           .= _time w
    , "exile"          .= _exile w
    , "battlefield"    .= _battlefield w
    , "stack"          .= _stack w
    , "command"        .= _command w
    ]



instance ToJSON Step where
  toJSON phase = obj $ case phase of
    BeginningPhase step -> ("phase" .= String "beginning") : toJSONPairs step
    MainPhase ->           ("phase" .= String "main")      : []
    CombatPhase step ->    ("phase" .= String "combat")    : toJSONPairs step
    EndPhase step ->       ("phase" .= String "end")       : toJSONPairs step

instance ToJSONPairs BeginningStep where
  toJSONPairs step = ["step" .= String value]
    where
      value = case step of
        UntapStep  -> "untap"
        UpkeepStep -> "upkeep"
        DrawStep   -> "draw"

instance ToJSONPairs CombatStep where
  toJSONPairs step = ["step" .= String value]
    where
      value = case step of
        BeginningOfCombatStep -> "beginningOfCombat"
        DeclareAttackersStep  -> "declareAttackers"
        DeclareBlockersStep   -> "declareBlockers"
        CombatDamageStep      -> "combatDamage"
        EndOfCombatStep       -> "endOfCombat"

instance ToJSONPairs EndStep where
  toJSONPairs step = ["step" .= String value]
    where
      value = case step of
        EndOfTurnStep -> "endOfTurn"
        CleanupStep   -> "cleanup"



instance ToJSON Player where
  toJSON p = obj
    [ "life"      .= _life p
    , "manaPool"  .= _manaPool p
    , "library"   .= _library p
    , "hand"      .= _hand p
    , "graveyard" .= _graveyard p
    ]



instance ToJSON (ObjectOfType a) where
  toJSON (CardObject o) = obj (toJSONPairs o)
  toJSON p@(Permanent {}) =
      obj (toJSONPairs (_permanentObject p) ++ permProps)
    where
      permProps = [ "tapStatus" .= _tapStatus p, "damage"    .= _damage p ]
  toJSON (StackItem o _) = obj (toJSONPairs o)

instance ToJSONPairs Object where
  toJSONPairs o =
    [ "name" .= _name o
    , "colors" .= _colors o
    , "types" .= _types o
    , "ownerId" .= _owner o
    , "controllerId" .= _controller o
    , "timestamp" .= _timestamp o
    , "counters" .= _counters o
    , "pt" .= maybe Null (\(p,t) -> obj [ "power" .= p, "toughness" .= t ]) (_pt o)
    , "staticKeywordAbilities" .= _staticKeywordAbilities o
    ]



instance ToJSON Color where
  toJSON = toJSON . map toLower . show

instance ToJSON TapStatus where
  toJSON = toJSON . map toLower . show

instance ToJSON CounterType where
  toJSON = toJSON . map toLower . show



instance ToJSON ObjectTypes where
  toJSON tys = obj
    [ "supertypes"        .= supertypes tys
    , "artifactTypes"     .= artifactSubtypes tys
    , "creatureTypes"     .= creatureSubtypes tys
    , "enchantmentTypes"  .= enchantmentSubtypes tys
    , "instantTypes"      .= instantSubtypes tys
    , "landTypes"         .= landSubtypes tys
    , "planeswalkerTypes" .= planeswalkerSubtypes tys
    ]

instance ToJSON Supertype           where toJSON = toJSON . show
instance ToJSON ArtifactSubtype     where toJSON = toJSON . show
instance ToJSON CreatureSubtype     where toJSON = toJSON . show
instance ToJSON EnchantmentSubtype  where toJSON = toJSON . show
instance ToJSON SpellSubtype        where toJSON = toJSON . show
instance ToJSON LandSubtype         where toJSON = toJSON . show
instance ToJSON PlaneswalkerSubtype where toJSON = toJSON . show


instance ToJSON StaticKeywordAbility where
  toJSON = \case
    FirstStrike -> "first strike"
    ProtectionFromColor c ->
      toJSON ("protection from " ++ map toLower (show c))
    ab -> (toJSON . map toLower . show) ab

instance ToJSON PriorityAction where
  toJSON a = typedObject $ case a of
    PlayCard r        -> ("playCard", [ "objectRef" .= objectRefToJSON r ])
    ActivateAbility r -> ("activateAbility", [ "activatedAbilityRef" .= activatedAbilityRefToJSON r ])

instance ToJSON PayManaAction where
  toJSON a = typedObject $ case a of
    PayManaFromManaPool mc ->
      ("payManaFromManaPool", [ "color" .= mc ])
    ActivateManaAbility r ->
      ("activateManaAbility", [ "activatedAbilityRef" .= activatedAbilityRefToJSON r])




instance ToJSON Event where
  toJSON event = typedObject $ case event of
    Did (GainLife p n)         -> ("gainLife",
      ["playerId" .= p, "amount" .= n])
    Did (LoseLife p n)         -> ("loseLife",
      ["playerId" .= p, "amount" .= n])
    Did (DamageObject _ (Battlefield, i) n c p) -> ("damageObject",
      [ "objectId" .= i, "amount" .= n, "isCombatDamage" .= c ])
    Did (DamagePlayer _ r n c p) -> ("damagePlayer",
      [ "playerId" .= r, "amount" .= n, "isCombatDamage" .= c ])
    Did (ShuffleLibrary p)       -> ("shuffleLibrary", [ "playerId" .= p ])
    Did (DrawCard p)             -> ("drawCard", [ "playerId" .= p ])
    Did (DestroyPermanent (Battlefield, i) _)   -> ("destroyPermanent", [ "objectId" .= i ])
    Did (TapPermanent (Battlefield, i)) -> ("tapPermanent", [ "objectId" .= i ])
    Did (UntapPermanent (Battlefield, i)) -> ("untapPermanent", [ "objectId" .= i ])
    Did (AddToManaPool p m)      -> ("addToManaPool",
      [ "playerId" .= p, "mana" .= m ])
    Did (SpendFromManaPool p m)  -> ("spendFromManaPool",
      [ "playerId" .= p, "mana" .= m ])
    Did (PlayLand p r)           -> ("playLand",
      [ "playerId" .= p, "objectRef" .= someObjectRefToJSON r ])
    Did (LoseGame p)             -> ("loseGame", [ "playerId" .= p ])
    Did (WinGame p)              -> ("winGame", [ "playerId" .= p ])
    Did (CeaseToExist r)         -> ("ceaseToExist",
      [ "objectRef" .= someObjectRefToJSON r ])
    DidMoveObject mOldRef newRef -> ("moveObject",
      [ "oldRef" .= maybe Null someObjectRefToJSON mOldRef
      , "newRef" .= someObjectRefToJSON newRef ])
    DidDeclareAttackers p ats      -> ("declareAttackers",
      [ "playerId" .= p, "attacks" .= ats ])
    DidBeginStep step            -> ("beginStep", [ "step" .= step ])
    WillEndStep step             -> ("willEndStep", [ "step" .= step ])
    _ -> error ("unhandled event: " ++ show event)

instance ToJSON Attack where
  toJSON (Attack atr atee) = obj [ "attacker" .= atr, "attackee" .= atee ]

instance ToJSON GameOver where
  toJSON t = typedObject $ case t of
    GameWin p -> ("gameWin", [ "playerId" .= p ])
    GameDraw -> ("gameDraw", [])
    ErrorWithMessage msg -> ("error", [ "message" .= msg ])

instance ToJSON EntityRef where
  toJSON t = typedObject $ case t of
    PlayerRef p -> ("player", [ "playerId" .= p ])
    ObjectRef r -> ("object", [ "objectRef" .= someObjectRefToJSON r ])

instance FromJSON EntityRef where
  parseJSON = Aeson.withObject "EntityRef" $ \o -> do
    ty <- o .: "type" :: Parser Text
    case ty of
      "player" -> PlayerRef <$> o .: "playerId"
      "object" -> do ObjectRef <$> (o .: "objectRef" >>= someObjectRefFromJSON)
      _ -> mzero

interactToJSON :: Monad m => m ByteString -> Interact a -> (Value, m a)
interactToJSON receiveData op = (typedObject (instrType, props), receiveAnswer)
  where
    (instrType, props, receiveAnswer) = case op of
      Debug msg -> ("debug", [ "message" .= msg ], return ())
      LogEvents _source events world ->
        ("logEvents", [ "events" .= events, "world" .= world ], return ())
      AskQuestion p w q ->
        let (json, select) = questionToJSON q
            getAnswer = do
              input <- receiveData
              case fmap (parse (unwrapAnswer select)) (decode input) of
                Nothing -> do
                  trace ("Invalid JSON input from client: " ++ BS.unpack input) $
sendText ( " Invalid option " : : Text )
                    getAnswer
                Just (Aeson.Error e) ->
                  trace ("Invalid input from client: " ++ BS.unpack input ++ ": " ++ e) $
sendText ( " Invalid option " : : Text )
                    getAnswer
                Just (Aeson.Success x) ->
                  return x
            unwrapAnswer :: (Value -> Parser a) -> Value -> Parser a
            unwrapAnswer k =
              Aeson.withObject "answer object" ((.: "answer") >=> k)
          in ("askQuestion", [ "playerId" .= p, "world" .= w, "question" .= json], getAnswer)

questionToJSON :: Question a -> (Value, Value -> Parser a)
questionToJSON q = (typedObject (questionType, props), select)
  where
    (questionType, props, select) = case q of
      AskKeepHand ->
        ("keepHand", [ ], Aeson.withBool "boolean" return)
      AskPriorityAction opts ->
        ("priorityAction", [ "options" .= (passOption : map toJSON opts) ],
          parseOptionIndex (Nothing : map Just opts))
      AskManaAbility m opts ->
        ("manaAbility", [ "manaToPay" .= m, "options" .= opts ],
          parseOptionIndex opts)
      AskTarget ts ->
        ("target", ["options" .= ts], parseOptionIndex ts)
      AskPickTrigger lkis ->
        ("pickTrigger", ["options" .= map lkiToJSON lkis],
          parseOptionIndex [0..length lkis - 1])
      AskAttackers as ts ->
        ("attack", [ "attackers" .= as, "targets" .= ts ],
          parseAttacks)

    parseOptionIndex :: [a] -> Value -> Parser a
    parseOptionIndex opts =
      withIntegral "option index" $ \i ->
        case atMay opts i of
          Just opt -> return opt
          Nothing  -> fail ("invalid option index: " ++ show i)

    parseAttacks :: Value -> Parser [Attack]
    parseAttacks = parseArray $ Aeson.withObject "object" parseAttack

    parseAttack :: Aeson.Object -> Parser Attack
    parseAttack at = do
      a <- at .: "attacker"
      t <- at .: "attackee" :: Parser EntityRef
      (Some Battlefield, i) <- someObjectRefFromJSON a
      return (Attack (Battlefield, i) t)

    parseArray :: (Value -> Parser a) -> Value -> Parser [a]
    parseArray parseElement = Aeson.withArray "array" $ \vs ->
      for (Vector.toList vs) parseElement

passOption :: Value
passOption = toJSON (typedObject ("pass", []))
