{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
-------------------------------------------------------------------------------
-- |
-- Module       : Generator.Parser
-- Copyright    : (c) 2016 Michael Carpenter
-- License      : BSD3
-- Maintainer   : Michael Carpenter <oldmanmike.dev@gmail.com>
-- Stability    : experimental
-- Portability  : portable
--
-------------------------------------------------------------------------------
module Generator.Parser
  ( ExtractedProtocolVersions (..)
  , ExtractedProtocolVersion (..)
  , ExtractedVersion (..)
  , ExtractedModernProtocol (..)
  , ExtractedClassicProtocol (..)
  , ExtractedPackets (..)
  , ExtractedPacket (..)
  , ExtractedField (..)
  , ExtractedFieldType (..)
  , ExtractedBitFields (..)
  , ExtractedBitField (..)
  , ExtractedSwitch (..)
  , ExtractedContainer (..)
  , ExtractedMapper (..)
  , ExtractedBuffer (..)
  , ExtractedCount (..)
  , ExtractedArray (..)
  ) where

import qualified  Control.Lens as Lens
import            Control.Monad
import            Data.Aeson
import            Data.Aeson.Types
import            Data.Data
import qualified  Data.Foldable as Foldable
import qualified  Data.HashMap.Strict as H
import qualified  Data.Text as T
import            GHC.Generics hiding (moduleName)

newtype ExtractedProtocolVersions =
  ExtractedProtocolVersions [ExtractedProtocolVersion] deriving (Show,Eq)


instance FromJSON ExtractedProtocolVersions where
  parseJSON (Array a) =
    ExtractedProtocolVersions <$> sequence (fmap parseJSON (Foldable.toList a))
  parseJSON invalid = typeMismatch "ExtractedProtocolVersions" invalid


data ExtractedProtocolVersion = ExtractedProtocolVersion
  { pMinecraftVersion   :: T.Text
  , pVersion            :: Int
  , pUsesNetty          :: Bool
  , pMajorVersion       :: T.Text
  } deriving (Show,Eq)


instance FromJSON ExtractedProtocolVersion where
  parseJSON (Object a) = ExtractedProtocolVersion
    <$> a .: "minecraftVersion"
    <*> a .: "version"
    <*> a .: "usesNetty"
    <*> a .: "majorVersion"
  parseJSON invalid = typeMismatch "ExtractedProtocolVersion" invalid


data ExtractedVersion = ExtractedVersion
  { eVersion           :: Int
  , eMinecraftVersion  :: T.Text
  , eMajorVersion      :: T.Text
  } deriving (Show,Eq,Generic,Data,Typeable)


instance FromJSON ExtractedVersion where
  parseJSON (Object a) = ExtractedVersion
    <$> a .: "version"
    <*> a .: "minecraftVersion"
    <*> a .: "majorVersion"
  parseJSON invalid = typeMismatch "ExtractedVersion" invalid


data ExtractedModernProtocol = ExtractedModernProtocol
  { modernClientBoundHandshaking  :: ExtractedPackets
  , modernServerBoundHandshaking  :: ExtractedPackets
  , modernClientBoundStatus       :: ExtractedPackets
  , modernServerBoundStatus       :: ExtractedPackets
  , modernClientBoundLogin        :: ExtractedPackets
  , modernServerBoundLogin        :: ExtractedPackets
  , modernClientBoundPlay         :: ExtractedPackets
  , modernServerBoundPlay         :: ExtractedPackets
  } deriving (Show,Eq)


instance FromJSON ExtractedModernProtocol where
  parseJSON (Object a) = do

    handshaking <- a .: "handshaking"

    hToClient <- handshaking .: "toClient"
    hCPackets <- hToClient .: "types"
    hClientBound <- parseJSON hCPackets

    hToServer <- handshaking .: "toServer"
    hSPackets <- hToServer .: "types"
    hServerBound <- parseJSON hSPackets

    status <- a .: "status"

    sToClient <- status .: "toClient"
    sCPackets <- sToClient .: "types"
    sClientBound <- parseJSON sCPackets

    sToServer <- status .: "toServer"
    sSPackets <- sToServer .: "types"
    sServerBound <- parseJSON sSPackets

    login <- a .: "login"

    lToClient <- login .: "toClient"
    lCPackets <- lToClient .: "types"
    lClientBound <- parseJSON lCPackets

    lToServer <- login .: "toServer"
    lSPackets <- lToServer .: "types"
    lServerBound <- parseJSON lSPackets

    play <- a .: "play"

    pToClient <- play .: "toClient"
    pCPackets <- pToClient .: "types"
    pClientBound <- parseJSON pCPackets

    pToServer <- play .: "toServer"
    pSPackets <- pToServer .: "types"
    pServerBound <- parseJSON pSPackets

    return (ExtractedModernProtocol hClientBound hServerBound sClientBound sServerBound lClientBound lServerBound pClientBound pServerBound)

  parseJSON _ = mzero


data ExtractedClassicProtocol = ExtractedClassicProtocol
  { classicServerBound  :: ExtractedPackets
  , classicClientBound  :: ExtractedPackets
  } deriving (Show,Eq)


instance FromJSON ExtractedClassicProtocol where
  parseJSON (Object a) = do
    toServer <- a .: "toServer"
    toServerTypes <- toServer .: "types"
    serverBound <- parseJSON toServerTypes

    toClient <- a .: "toClient"
    toClientTypes <- toClient .: "types"
    clientBound <- parseJSON toClientTypes

    return (ExtractedClassicProtocol serverBound clientBound)

  parseJSON invalid = typeMismatch "ExtractedClassicProtocol" invalid


newtype ExtractedPackets = ExtractedPackets
  { getPackets :: [ExtractedPacket]
  } deriving (Show,Eq)


data ExtractedPacket = ExtractedPacket
  { ePacketName   :: T.Text
  , ePacketField  :: [ExtractedField]
  } deriving (Show,Eq)


instance FromJSON ExtractedPackets where
  parseJSON (Object a) = do
    let subparsers =
          [ ExtractedPacket key <$> parseJSON packets
          | (key, Array values) <- Lens.itoList a
          , packets@(Array _) <- Foldable.toList values
          , strings@(String _) <- Foldable.toList values]
    packets <- sequence subparsers
    return (ExtractedPackets packets)
  parseJSON invalid = typeMismatch "ExtractedPacketField" invalid


data ExtractedField = ExtractedField
  { eFieldName :: Maybe T.Text
  , eFieldType :: ExtractedFieldType
  , eFieldAnon :: Maybe Bool
  } deriving (Show,Eq,Generic,Data,Typeable)


instance FromJSON ExtractedField where
  parseJSON (Object a) = ExtractedField
    <$> a .:? "name"
    <*> a .: "type"
    <*> a .:? "anon"
  parseJSON invalid = typeMismatch "ExtractedField" invalid


data ExtractedFieldType
  = ExtractedVarIntType
  | ExtractedPStringType
  | ExtractedU8Type
  | ExtractedU16Type
  | ExtractedU32Type
  | ExtractedU64Type
  | ExtractedI8Type
  | ExtractedI16Type
  | ExtractedI32Type
  | ExtractedI64Type
  | ExtractedF32Type
  | ExtractedF64Type
  | ExtractedBoolType
  | ExtractedUUIDType
  | ExtractedOptionType ExtractedFieldType
  | ExtractedEntityMetadataLoopType
  | ExtractedVoidType
  | ExtractedRestBufferType
  | ExtractedNBTType
  | ExtractedCompressedNBTType
  | ExtractedStringType
  | ExtractedSlotType
  | ExtractedPositionType
  | ExtractedPositionIIIType
  | ExtractedPositionISIType
  | ExtractedPositionIBIType
  | ExtractedEntityMetadataItemType
  | ExtractedEntityMetadataType
  | ExtractedSwitchType ExtractedSwitch
  | ExtractedContainerType ExtractedContainer
  | ExtractedMapperType ExtractedMapper
  | ExtractedBufferType ExtractedBuffer
  | ExtractedArrayType ExtractedArray
  | ExtractedCountType ExtractedCount
  | ExtractedBitFieldsType ExtractedBitFields
  | ExtractedCustomField T.Text
  | ExtractedByteArray
  deriving (Show,Eq,Data,Typeable)


instance FromJSON ExtractedFieldType where
  parseJSON v = do
    case v of
      (String s) -> do
        case s of
          "varint"              -> return ExtractedVarIntType
          "pstring"             -> return ExtractedPStringType
          "u8"                  -> return ExtractedU8Type
          "u16"                 -> return ExtractedU16Type
          "u32"                 -> return ExtractedU32Type
          "u64"                 -> return ExtractedU64Type
          "i8"                  -> return ExtractedI8Type
          "i16"                 -> return ExtractedI16Type
          "i32"                 -> return ExtractedI32Type
          "i64"                 -> return ExtractedI64Type
          "f32"                 -> return ExtractedF32Type
          "f64"                 -> return ExtractedF64Type
          "bool"                -> return ExtractedBoolType
          "UUID"                -> return ExtractedUUIDType
          "entityMetadataLoop"  -> return ExtractedEntityMetadataLoopType
          "void"                -> return ExtractedVoidType
          "restBuffer"          -> return ExtractedRestBufferType
          "nbt"                 -> return ExtractedNBTType
          "compressedNbt"       -> return ExtractedCompressedNBTType
          "optionalNbt"         -> return ExtractedNBTType
          "string"              -> return ExtractedStringType
          "slot"                -> return ExtractedSlotType
          "position"            -> return ExtractedPositionType
          "position_iii"        -> return ExtractedPositionIIIType
          "position_isi"        -> return ExtractedPositionISIType
          "position_ibi"        -> return ExtractedPositionIBIType
          "entityMetadataItem"  -> return ExtractedEntityMetadataItemType
          "entityMetadata"      -> return ExtractedEntityMetadataType
          "byte_array"          -> return ExtractedByteArray
          _                     -> return (ExtractedCustomField s)
      (Array a) -> do
        let objects = [(key,x)
                      | key@(String _) <- Foldable.toList a
                      , x@(Object _) <- Foldable.toList a
                      , (key == "mapper")
                        || (key == "switch")
                        || (key == "buffer")
                        || (key == "array")
                        || (key == "count")]
        let arrays = [(key,x)
                      | key@(String _) <- Foldable.toList a
                      , x@(Array _) <- Foldable.toList a
                      , (key == "container")
                        || (key == "bitfield")]
        let strings = [(key,x)
                      | key@(String _) <- Foldable.toList a
                      , x@(String _) <- Foldable.toList a
                      , (key == "option")]
        case (head (objects ++ arrays ++ strings)) of
          ("mapper",m)    -> ExtractedMapperType <$> parseJSON m
          ("switch",s)    -> ExtractedSwitchType <$> parseJSON s
          ("buffer",b1)    -> ExtractedBufferType <$> parseJSON b1
          ("container",c1) -> ExtractedContainerType <$> parseJSON c1
          ("array",a)     -> ExtractedArrayType <$> parseJSON a
          ("count",c2)    -> ExtractedCountType <$> parseJSON c2
          ("bitfield",b2) -> ExtractedBitFieldsType <$> parseJSON b2
          ("option",o)    -> ExtractedOptionType <$> parseJSON o
          _ -> typeMismatch "ExtractedFieldType" v
      _ -> typeMismatch "ExtractedFieldType" v


data ExtractedBitFields = ExtractedBitFields
  { bitfieldFields :: [ExtractedBitField]
  } deriving (Show,Eq,Data,Typeable)


instance FromJSON ExtractedBitFields where
  parseJSON (Array a) = ExtractedBitFields <$> sequence (fmap parseJSON (Foldable.toList a))
  parseJSON invalid = typeMismatch "ExtractedBitFields" invalid


data ExtractedBitField = ExtractedBitField
  { bitfieldName    :: T.Text
  , bitfieldSize    :: Int
  , bitfieldSigned  :: Bool
  } deriving (Show,Eq,Data,Typeable)


instance FromJSON ExtractedBitField where
  parseJSON (Object a) = ExtractedBitField
    <$> a .: "name"
    <*> a .: "size"
    <*> a .: "signed"
  parseJSON invalid = typeMismatch "ExtractedBitField" invalid


data ExtractedSwitch = ExtractedSwitch
  { eSwitchCompareTo :: T.Text
  , eSwitchFields    :: H.HashMap T.Text ExtractedFieldType
  , eSwitchDefault   :: Maybe ExtractedFieldType
  } deriving (Show,Eq,Data,Typeable)


instance FromJSON ExtractedSwitch where
  parseJSON (Object a) = ExtractedSwitch
    <$> a .: "compareTo"
    <*> a .: "fields"
    <*> a .:? "default"
  parseJSON invalid = typeMismatch "ExtractedSwitch" invalid


data ExtractedContainer = ExtractedContainer [ExtractedField]
  deriving (Show,Eq,Data,Typeable)


instance FromJSON ExtractedContainer where
  parseJSON (Array a) = ExtractedContainer <$> sequence (fmap parseJSON (Foldable.toList a))
  parseJSON invalid = typeMismatch "ExtractedContainer" invalid


data ExtractedMapper = ExtractedMapper
  { mapperType    :: T.Text
  , mapperMappings  :: H.HashMap T.Text T.Text
  } deriving (Show,Eq,Data,Typeable)


instance FromJSON ExtractedMapper where
  parseJSON (Object a) = ExtractedMapper
    <$> a .: "type"
    <*> a .: "mappings"
  parseJSON invalid = typeMismatch "ExtractedSwitch" invalid


data ExtractedBuffer = ExtractedBuffer
  { bufferCountType   :: Either T.Text ExtractedFieldType
  } deriving (Show,Eq,Data,Typeable)


instance FromJSON ExtractedBuffer where
  parseJSON (Object a) = do
    c <- a .:? "count"
    ct <- a .:? "countType"
    case (c,ct) of
      (Just c',Just ct')  -> undefined
      (Just c',Nothing)   -> ExtractedBuffer <$> fmap Left (parseJSON (String c'))
      (Nothing,Just ct')  -> ExtractedBuffer <$> fmap Right (parseJSON (String ct'))
      (Nothing,Nothing)   -> undefined
  parseJSON invalid = typeMismatch "ExtractedBuffer" invalid


data ExtractedCount = ExtractedCount
  { eCountType  :: ExtractedFieldType
  , eCountFor   :: T.Text
  } deriving (Show,Eq,Data,Typeable)


instance FromJSON ExtractedCount where
  parseJSON (Object a) = ExtractedCount
    <$> (a .: "type")
    <*> a .: "countFor"
  parseJSON invalid = typeMismatch "ExtractedCount" invalid


data ExtractedArray = ExtractedArray
  { arrayCountType  :: Maybe T.Text
  , arrayType       :: ExtractedFieldType
  , arrayCount      :: Maybe (Either T.Text Int)
  } deriving (Show,Eq,Data,Typeable)


instance FromJSON ExtractedArray where
  parseJSON (Object a) = do
    someCount <- a .:? "count"
    case someCount of
      Just (String s) -> ExtractedArray
                          <$> a .:? "countType"
                          <*> a .: "type"
                          <*> (fmap Just (fmap Left (a .: "count")))
      Just (Number n) -> ExtractedArray
                          <$> a .:? "countType"
                          <*> a .: "type"
                          <*> (fmap Just (fmap Right (a .: "count")))
      Nothing         -> ExtractedArray
                          <$> a .:? "countType"
                          <*> a .: "type"
                          <*> a .:? "count"

  parseJSON invalid = typeMismatch "ExtractedArray" invalid
