diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,5 @@ +module Main (main) where + import qualified Distribution.Simple diff --git a/library/Octane/Data.hs b/library/Octane/Data.hs --- a/library/Octane/Data.hs +++ b/library/Octane/Data.hs @@ -25,7 +25,8 @@ -- >>> Map.lookup "TheWorld:PersistentLevel.InMapScoreboard_TA" classes -- Just "TAGame.InMapScoreboard_TA" classes :: Map.Map StrictText.Text StrictText.Text -classes = Embed.decodeMap $(FileEmbed.embedFile "data/classes.json") +classes = Embed.decodeMap + $(FileEmbed.embedFile "data/classes.json") -- | A set of classes that have an initial location vector. @@ -33,7 +34,8 @@ -- >>> Set.member "TAGame.Ball_TA" classesWithLocation -- True classesWithLocation :: Set.Set StrictText.Text -classesWithLocation = Embed.decodeSet $(FileEmbed.embedFile "data/classes-with-location.json") +classesWithLocation = Embed.decodeSet + $(FileEmbed.embedFile "data/classes-with-location.json") -- | A set of classes that have an initial rotation vector. @@ -41,7 +43,8 @@ -- >>> Set.member "TAGame.Ball_TA" classesWithRotation -- True classesWithRotation :: Set.Set StrictText.Text -classesWithRotation = Embed.decodeSet $(FileEmbed.embedFile "data/classes-with-rotation.json") +classesWithRotation = Embed.decodeSet + $(FileEmbed.embedFile "data/classes-with-rotation.json") -- | A one-to-one mapping between game mode IDs and their names. @@ -49,7 +52,8 @@ -- >>> Bimap.lookup 1 gameModes :: Maybe StrictText.Text -- Just "Hockey" gameModes :: Bimap.Bimap Int StrictText.Text -gameModes = Embed.decodeBimap $(FileEmbed.embedFile "data/game-modes.json") +gameModes = Embed.decodeBimap + $(FileEmbed.embedFile "data/game-modes.json") -- | A one-to-one mapping between product IDs and their names. @@ -57,7 +61,8 @@ -- >>> Bimap.lookup 1 products :: Maybe StrictText.Text -- Just "Antenna_8Ball" products :: Bimap.Bimap Word StrictText.Text -products = Embed.decodeBimap $(FileEmbed.embedFile "data/products.json") +products = Embed.decodeBimap + $(FileEmbed.embedFile "data/products.json") -- | A mapping between property names and their serialized type. @@ -65,4 +70,5 @@ -- >>> Map.lookup "Engine.Actor:bBlockActors" properties -- Just "boolean" properties :: Map.Map StrictText.Text StrictText.Text -properties = Embed.decodeMap $(FileEmbed.embedFile "data/properties.json") +properties = Embed.decodeMap + $(FileEmbed.embedFile "data/properties.json") diff --git a/library/Octane/Type/Boolean.hs b/library/Octane/Type/Boolean.hs --- a/library/Octane/Type/Boolean.hs +++ b/library/Octane/Type/Boolean.hs @@ -1,5 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Boolean (Boolean(..)) where @@ -11,6 +17,8 @@ import qualified Data.Binary.Bits as BinaryBit import qualified Data.Binary.Bits.Get as BinaryBit import qualified Data.Binary.Bits.Put as BinaryBit +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics -- $setup @@ -20,14 +28,16 @@ -- | A boolean value. newtype Boolean = Boolean - { unpack :: Bool + { booleanUnpack :: Bool } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''Boolean) + -- | Stored in the last bit of a byte. Decoding will fail if the byte is -- anything other than @0b00000000@ or @0b00000001@. -- -- >>> Binary.decode "\x01" :: Boolean --- Boolean {unpack = True} +-- Boolean {booleanUnpack = True} -- -- >>> Binary.encode (Boolean True) -- "\SOH" @@ -40,7 +50,7 @@ _ -> fail ("Unexpected Boolean value " ++ show value) put boolean = boolean - & unpack + & #unpack & fromEnum & fromIntegral & Binary.putWord8 @@ -48,7 +58,7 @@ -- | Stored as a bit. -- -- >>> Binary.runGet (BinaryBit.runBitGet (BinaryBit.getBits 0)) "\x80" :: Boolean --- Boolean {unpack = True} +-- Boolean {booleanUnpack = True} -- -- >>> Binary.runPut (BinaryBit.runBitPut (BinaryBit.putBits 0 (Boolean True))) -- "\128" @@ -58,7 +68,7 @@ value & Boolean & pure putBits _ boolean = boolean - & unpack + & #unpack & BinaryBit.putBool instance DeepSeq.NFData Boolean where @@ -69,5 +79,5 @@ -- "true" instance Aeson.ToJSON Boolean where toJSON boolean = boolean - & unpack + & #unpack & Aeson.toJSON diff --git a/library/Octane/Type/CacheItem.hs b/library/Octane/Type/CacheItem.hs --- a/library/Octane/Type/CacheItem.hs +++ b/library/Octane/Type/CacheItem.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.CacheItem (CacheItem(..)) where @@ -8,6 +14,8 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.CacheProperty as CacheProperty import qualified Octane.Type.List as List @@ -19,20 +27,22 @@ -- | An item in the class net cache map. data CacheItem = CacheItem - { classId :: Word32.Word32 + { cacheItemClassId :: Word32.Word32 -- ^ The class ID. - , parentCacheId :: Word32.Word32 + , cacheItemParentCacheId :: Word32.Word32 -- ^ The cache ID of the parent class. - , cacheId :: Word32.Word32 + , cacheItemCacheId :: Word32.Word32 -- ^ The cache ID of the class. - , properties :: List.List CacheProperty.CacheProperty + , cacheItemProperties :: List.List CacheProperty.CacheProperty -- ^ The properties that belong to this class. } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''CacheItem) + -- | Fields are stored one after the other in order. -- -- >>> Binary.decode "\x01\x00\x00\x00\x02\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00" :: CacheItem --- CacheItem {classId = 0x00000001, parentCacheId = 0x00000002, cacheId = 0x00000003, properties = fromList []} +-- CacheItem {cacheItemClassId = 0x00000001, cacheItemParentCacheId = 0x00000002, cacheItemCacheId = 0x00000003, cacheItemProperties = fromList []} -- -- >>> Binary.encode (CacheItem 1 2 3 []) -- "\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" @@ -44,9 +54,9 @@ <*> Binary.get put cacheItem = do - cacheItem & classId & Binary.put - cacheItem & parentCacheId & Binary.put - cacheItem & cacheId & Binary.put - cacheItem & properties & Binary.put + cacheItem & #classId & Binary.put + cacheItem & #parentCacheId & Binary.put + cacheItem & #cacheId & Binary.put + cacheItem & #properties & Binary.put instance DeepSeq.NFData CacheItem where diff --git a/library/Octane/Type/CacheProperty.hs b/library/Octane/Type/CacheProperty.hs --- a/library/Octane/Type/CacheProperty.hs +++ b/library/Octane/Type/CacheProperty.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.CacheProperty (CacheProperty(..)) where @@ -8,22 +14,26 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.Word32 as Word32 -- | A property on an item in the class net cache map. data CacheProperty = CacheProperty - { objectId :: Word32.Word32 + { cachePropertyObjectId :: Word32.Word32 -- ^ The object's ID. - , streamId :: Word32.Word32 + , cachePropertyStreamId :: Word32.Word32 -- ^ The object's ID in the network stream. } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''CacheProperty) + -- | Fields are stored one after the other in order. -- -- >>> Binary.decode "\x01\x00\x00\x00\x02\x00\x00\x00" :: CacheProperty --- CacheProperty {objectId = 0x00000001, streamId = 0x00000002} +-- CacheProperty {cachePropertyObjectId = 0x00000001, cachePropertyStreamId = 0x00000002} -- -- >>> Binary.encode (CacheProperty 1 2) -- "\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL" @@ -33,7 +43,7 @@ <*> Binary.get put cacheProperty = do - cacheProperty & objectId & Binary.put - cacheProperty & streamId & Binary.put + cacheProperty & #objectId & Binary.put + cacheProperty & #streamId & Binary.put instance DeepSeq.NFData CacheProperty where diff --git a/library/Octane/Type/ClassItem.hs b/library/Octane/Type/ClassItem.hs --- a/library/Octane/Type/ClassItem.hs +++ b/library/Octane/Type/ClassItem.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.ClassItem (ClassItem(..)) where @@ -8,6 +14,8 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text import qualified Octane.Type.Word32 as Word32 @@ -16,16 +24,18 @@ -- | A class (like @Core.Object@) and it's associated ID in the net stream -- (like @0@). data ClassItem = ClassItem - { name :: Text.Text + { classItemName :: Text.Text -- ^ The class's name. - , streamId :: Word32.Word32 + , classItemStreamId :: Word32.Word32 -- ^ The class's ID in the network stream. } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''ClassItem) + -- | Fields are stored one after the other in order. -- -- >>> Binary.decode "\x02\x00\x00\x00\x4b\x00\x01\x00\x00\x00" :: ClassItem --- ClassItem {name = "K", streamId = 0x00000001} +-- ClassItem {classItemName = "K", classItemStreamId = 0x00000001} -- -- >>> Binary.encode (ClassItem "K" 1) -- "\STX\NUL\NUL\NULK\NUL\SOH\NUL\NUL\NUL" @@ -35,7 +45,7 @@ <*> Binary.get put classItem = do - classItem & name & Binary.put - classItem & streamId & Binary.put + classItem & #name & Binary.put + classItem & #streamId & Binary.put instance DeepSeq.NFData ClassItem where diff --git a/library/Octane/Type/CompressedWord.hs b/library/Octane/Type/CompressedWord.hs --- a/library/Octane/Type/CompressedWord.hs +++ b/library/Octane/Type/CompressedWord.hs @@ -1,7 +1,19 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -module Octane.Type.CompressedWord (CompressedWord(..), fromCompressedWord) where +module Octane.Type.CompressedWord + ( CompressedWord(..) + , fromCompressedWord + ) where import Data.Aeson ((.=)) import Data.Function ((&)) @@ -12,6 +24,8 @@ import qualified Data.Binary.Bits.Get as BinaryBit import qualified Data.Binary.Bits.Put as BinaryBit import qualified Data.Bits as Bits +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean @@ -25,33 +39,35 @@ -- limit, or the number of bits necessary to reach the limit has been reached, -- whichever comes first. data CompressedWord = CompressedWord - { limit :: Word - , value :: Word + { compressedWordLimit :: Word + , compressedWordValue :: Word } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''CompressedWord) + -- | Abuses the first argument to 'BinaryBit.getBits' as the maximum value. -- -- >>> Binary.runGet (BinaryBit.runBitGet (BinaryBit.getBits 4)) "\x7f" :: CompressedWord --- CompressedWord {limit = 4, value = 2} +-- CompressedWord {compressedWordLimit = 4, compressedWordValue = 2} -- -- >>> Binary.runPut (BinaryBit.runBitPut (BinaryBit.putBits 0 (CompressedWord 4 2))) -- "\128" instance BinaryBit.BinaryBit CompressedWord where getBits n = do - let theLimit = fromIntegral n - theValue <- getStep theLimit (bitSize theLimit) 0 0 - pure (CompressedWord theLimit theValue) + let limit = fromIntegral n + value <- getStep limit (bitSize limit) 0 0 + pure (CompressedWord limit value) putBits _ compressedWord = do - let theLimit = fromIntegral (limit compressedWord) - let theValue = fromIntegral (value compressedWord) - let maxBits = bitSize theLimit + let limit = fromIntegral (#limit compressedWord) + let value = fromIntegral (#value compressedWord) + let maxBits = bitSize limit let upper = (2 ^ (maxBits - 1)) - 1 - let lower = theLimit - upper - let numBits = if lower > theValue || theValue > upper + let lower = limit - upper + let numBits = if lower > value || value > upper then maxBits else maxBits - 1 - BinaryBit.putWord64be numBits theValue + BinaryBit.putWord64be numBits value instance DeepSeq.NFData CompressedWord where @@ -61,8 +77,8 @@ -- "{\"Value\":1,\"Limit\":2}" instance Aeson.ToJSON CompressedWord where toJSON compressedWord = Aeson.object - [ "Limit" .= limit compressedWord - , "Value" .= value compressedWord + [ "Limit" .= #limit compressedWord + , "Value" .= #value compressedWord ] @@ -72,7 +88,7 @@ -- >>> fromCompressedWord (CompressedWord 2 1) :: Int -- 1 fromCompressedWord :: (Integral a) => CompressedWord -> a -fromCompressedWord compressedWord = compressedWord & value & fromIntegral +fromCompressedWord compressedWord = compressedWord & #value & fromIntegral bitSize :: (Integral a, Integral b) => a -> b @@ -80,11 +96,11 @@ getStep :: Word -> Word -> Word -> Word -> BinaryBit.BitGet Word -getStep theLimit maxBits position theValue = do +getStep limit maxBits position value = do let x = Bits.shiftL 1 (fromIntegral position) - if position < maxBits && theValue + x <= theLimit + if position < maxBits && value + x <= limit then do - bit <- BinaryBit.getBits 0 - let newValue = if Boolean.unpack bit then theValue + x else theValue - getStep theLimit maxBits (position + 1) newValue - else pure theValue + (bit :: Boolean.Boolean) <- BinaryBit.getBits 0 + let newValue = if #unpack bit then value + x else value + getStep limit maxBits (position + 1) newValue + else pure value diff --git a/library/Octane/Type/Dictionary.hs b/library/Octane/Type/Dictionary.hs --- a/library/Octane/Type/Dictionary.hs +++ b/library/Octane/Type/Dictionary.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Octane.Type.Dictionary (Dictionary(..)) where @@ -10,7 +15,9 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default import qualified Data.Map.Strict as Map +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Exts as Exts import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text @@ -22,9 +29,11 @@ -- | A mapping between text and arbitrary values. newtype Dictionary a = Dictionary - { unpack :: (Map.Map Text.Text a) + { dictionaryUnpack :: (Map.Map Text.Text a) } deriving (Eq, Generics.Generic) +$(OverloadedRecords.overloadedRecord Default.def ''Dictionary) + -- | Elements are stored with the key first, then the value. The dictionary -- ends when a key is @"None"@. -- @@ -43,7 +52,7 @@ elements & Map.union element & Dictionary & pure put dictionary = do - dictionary & unpack & Map.assocs & mapM_ putElement + dictionary & #unpack & Map.assocs & mapM_ putElement noneKey & Binary.put -- | Allows creating 'Dictionary' values with 'Exts.fromList'. Also allows @@ -56,7 +65,7 @@ fromList items = Dictionary (Map.fromList items) - toList dictionary = Map.toList (unpack dictionary) + toList dictionary = Map.toList (#unpack dictionary) instance (DeepSeq.NFData a) => DeepSeq.NFData (Dictionary a) where @@ -65,7 +74,7 @@ -- >>> show ([("one", 1)] :: Dictionary Int) -- "fromList [(\"one\",1)]" instance (Show a) => Show (Dictionary a) where - show dictionary = show (unpack dictionary) + show dictionary = show (#unpack dictionary) -- | Encoded directly as a JSON object. -- @@ -73,8 +82,8 @@ -- "{\"one\":1}" instance (Aeson.ToJSON a) => Aeson.ToJSON (Dictionary a) where toJSON dictionary = dictionary - & unpack - & Map.mapKeys Text.unpack + & #unpack + & Map.mapKeys #unpack & Aeson.toJSON diff --git a/library/Octane/Type/Float32.hs b/library/Octane/Type/Float32.hs --- a/library/Octane/Type/Float32.hs +++ b/library/Octane/Type/Float32.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Float32 (Float32(..)) where @@ -16,6 +22,8 @@ import qualified Data.Binary.IEEE754 as IEEE754 import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Utility.Endian as Endian @@ -26,9 +34,11 @@ -- | A 32-bit float. newtype Float32 = Float32 - { unpack :: Float + { float32Unpack :: Float } deriving (Eq, Fractional, Generics.Generic, Num, Ord) +$(OverloadedRecords.overloadedRecord Default.def ''Float32) + -- | Little-endian. -- -- >>> Binary.decode "\x9a\x99\x99\x3f" :: Float32 @@ -42,7 +52,7 @@ value & Float32 & pure put float32 = float32 - & unpack + & #unpack & IEEE754.putFloat32le -- | Little-endian with the bits in each byte reversed. @@ -75,7 +85,7 @@ -- >>> show (1.2 :: Float32) -- "1.2" instance Show Float32 where - show float32 = show (unpack float32) + show float32 = show (#unpack float32) -- | Encoded directly as a JSON number. -- @@ -83,5 +93,5 @@ -- "1.2" instance Aeson.ToJSON Float32 where toJSON float32 = float32 - & unpack + & #unpack & Aeson.toJSON diff --git a/library/Octane/Type/Frame.hs b/library/Octane/Type/Frame.hs --- a/library/Octane/Type/Frame.hs +++ b/library/Octane/Type/Frame.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Frame (Frame(..)) where @@ -12,13 +18,13 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Bimap as Bimap +import qualified Data.Default.Class as Default import qualified Data.Map.Strict as Map +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText import qualified GHC.Generics as Generics import qualified Octane.Data as Data -import qualified Octane.Type.CompressedWord as CompressedWord import qualified Octane.Type.Float32 as Float32 -import qualified Octane.Type.Initialization as Initialization import qualified Octane.Type.Replication as Replication import qualified Octane.Type.State as State import qualified Octane.Type.Value as Value @@ -31,29 +37,31 @@ -- This cannot be an instance of 'Data.Binary.Bits.BinaryBit' because it -- requires out-of-band information (the class property map) to decode. data Frame = Frame - { number :: Word + { frameNumber :: Word -- ^ This frame's number in the network stream. Starts at 0. - , isKeyFrame :: Bool + , frameIsKeyFrame :: Bool -- ^ Is this frame a key frame? - , time :: Float32.Float32 + , frameTime :: Float32.Float32 -- ^ The since the start of the match that this frame occurred. - , delta :: Float32.Float32 + , frameDelta :: Float32.Float32 -- ^ The time between the last frame and this one. - , replications :: [Replication.Replication] + , frameReplications :: [Replication.Replication] -- ^ A list of all the replications in this frame. } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''Frame) + instance DeepSeq.NFData Frame where instance Aeson.ToJSON Frame where toJSON frame = Aeson.object - [ "Number" .= number frame - , "IsKeyFrame" .= isKeyFrame frame - , "Time" .= time frame - , "Delta" .= delta frame - , "Spawned" .= (frame & replications & getSpawned) - , "Updated" .= (frame & replications & getUpdated) - , "Destroyed" .= (frame & replications & getDestroyed) + [ "Number" .= #number frame + , "IsKeyFrame" .= #isKeyFrame frame + , "Time" .= #time frame + , "Delta" .= #delta frame + , "Spawned" .= (frame & #replications & getSpawned) + , "Updated" .= (frame & #replications & getUpdated) + , "Destroyed" .= (frame & #replications & getDestroyed) ] @@ -62,12 +70,12 @@ instance Aeson.ToJSON Spawned where toJSON (Spawned xs) = xs & map (\ x -> do - let k = x & Replication.actorId & CompressedWord.value & show & StrictText.pack + let k = x & #actorId & #value & show & StrictText.pack let v = Aeson.object - [ "Name" .= Replication.objectName x - , "Class" .= Replication.className x - , "Position" .= (x & Replication.initialization & fmap Initialization.location) - , "Rotation" .= (x & Replication.initialization & fmap Initialization.rotation) + [ "Name" .= #objectName x + , "Class" .= #className x + , "Position" .= (x & #initialization & fmap #location) + , "Rotation" .= (x & #initialization & fmap #rotation) ] (k, v)) & Map.fromList @@ -76,7 +84,7 @@ getSpawned :: [Replication.Replication] -> Spawned getSpawned xs = xs & filter (\ x -> x - & Replication.state + & #state & (== State.SOpening)) & Spawned @@ -87,12 +95,12 @@ toJSON (Updated xs) = xs & map (\ x -> do let k = x - & Replication.actorId - & CompressedWord.value + & #actorId + & #value & show & StrictText.pack let v = x - & Replication.properties + & #properties & Map.map (\ value -> Aeson.object [ "Type" .= getType value , "Value" .= getValue value @@ -105,10 +113,10 @@ getUpdated :: [Replication.Replication] -> Updated getUpdated xs = xs & filter (\ x -> x - & Replication.state + & #state & (== State.SExisting)) & filter (\ x -> x - & Replication.properties + & #properties & null & not) & Updated @@ -118,14 +126,14 @@ instance Aeson.ToJSON Destroyed where toJSON (Destroyed xs) = xs - & map Replication.actorId - & map CompressedWord.value + & map #actorId + & map #value & Aeson.toJSON getDestroyed :: [Replication.Replication] -> Destroyed getDestroyed xs = xs & filter (\ x -> x - & Replication.state + & #state & (== State.SClosing)) & Destroyed diff --git a/library/Octane/Type/Initialization.hs b/library/Octane/Type/Initialization.hs --- a/library/Octane/Type/Initialization.hs +++ b/library/Octane/Type/Initialization.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Initialization ( Initialization(..) @@ -11,6 +17,8 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary.Bits.Get as BinaryBit import qualified Data.Binary.Bits.Put as BinaryBit +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Set as Set import qualified Data.Text as StrictText import qualified GHC.Generics as Generics @@ -24,34 +32,36 @@ -- This cannot be an instance of 'Data.Binary.Bits.BinaryBit' because it -- requires out-of-band information (the class name) to decode. data Initialization = Initialization - { location :: Maybe (Vector.Vector Int) + { initializationLocation :: Maybe (Vector.Vector Int) -- ^ The instance's initial position. - , rotation :: Maybe (Vector.Vector Int8.Int8) + , initializationRotation :: Maybe (Vector.Vector Int8.Int8) -- ^ The instance's initial rotation. } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''Initialization) + instance DeepSeq.NFData Initialization where -- | Gets the 'Initialization' for a given class. getInitialization :: StrictText.Text -> BinaryBit.BitGet Initialization getInitialization className = do - location' <- if Set.member className Data.classesWithLocation + location <- if Set.member className Data.classesWithLocation then fmap Just Vector.getIntVector else pure Nothing - rotation' <- if Set.member className Data.classesWithRotation + rotation <- if Set.member className Data.classesWithRotation then fmap Just Vector.getInt8Vector else pure Nothing - pure Initialization { location = location', rotation = rotation' } + pure Initialization { initializationLocation = location, initializationRotation = rotation } -- | Puts the 'Initialization'. Note that unlike 'getInitialization', this does -- not require the class name. putInitialization :: Initialization -> BinaryBit.BitPut () putInitialization initialization = do - case location initialization of + case #location initialization of Nothing -> pure () Just x -> Vector.putIntVector x - case rotation initialization of + case #rotation initialization of Nothing -> pure () Just x -> Vector.putInt8Vector x diff --git a/library/Octane/Type/Int32.hs b/library/Octane/Type/Int32.hs --- a/library/Octane/Type/Int32.hs +++ b/library/Octane/Type/Int32.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Int32 (Int32(..), fromInt32, toInt32) where @@ -15,16 +21,20 @@ import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default import qualified Data.Int as Int +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Utility.Endian as Endian -- | A 32-bit signed integer. newtype Int32 = Int32 - { unpack :: Int.Int32 + { int32Unpack :: Int.Int32 } deriving (Eq, Generics.Generic, Num, Ord) +$(OverloadedRecords.overloadedRecord Default.def ''Int32) + -- | Little-endian. -- -- >>> Binary.decode "\x01\x00\x00\x00" :: Int32 @@ -38,7 +48,7 @@ pure (Int32 value) put int32 = do - let value = unpack int32 + let value = #unpack int32 Binary.putInt32le value -- | Little-endian with the bits in each byte reversed. @@ -71,7 +81,7 @@ -- >>> show (1 :: Int32) -- "1" instance Show Int32 where - show int32 = show (unpack int32) + show int32 = show (#unpack int32) -- | Encoded as a JSON number directly. -- @@ -79,7 +89,7 @@ -- "1" instance Aeson.ToJSON Int32 where toJSON int32 = int32 - & unpack + & #unpack & Aeson.toJSON @@ -88,7 +98,7 @@ -- >>> fromInt32 1 :: Int.Int32 -- 1 fromInt32 :: (Integral a) => Int32 -> a -fromInt32 int32 = fromIntegral (unpack int32) +fromInt32 int32 = fromIntegral (#unpack int32) -- | Converts any 'Integral' value into a 'Int32'. diff --git a/library/Octane/Type/Int8.hs b/library/Octane/Type/Int8.hs --- a/library/Octane/Type/Int8.hs +++ b/library/Octane/Type/Int8.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Int8 (Int8(..), fromInt8, toInt8) where @@ -15,7 +21,9 @@ import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default import qualified Data.Int as Int +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Utility.Endian as Endian @@ -26,9 +34,11 @@ -- | A 8-bit signed integer. newtype Int8 = Int8 - { unpack :: Int.Int8 + { int8Unpack :: Int.Int8 } deriving (Eq, Generics.Generic, Num, Ord) +$(OverloadedRecords.overloadedRecord Default.def ''Int8) + -- | >>> Binary.decode "\x01" :: Int8 -- 1 -- @@ -40,7 +50,7 @@ pure (Int8 value) put int8 = do - let value = unpack int8 + let value = #unpack int8 Binary.putInt8 value -- | Stored with the bits reversed. @@ -73,7 +83,7 @@ -- >>> show (1 :: Int8) -- "1" instance Show Int8 where - show int8 = show (unpack int8) + show int8 = show (#unpack int8) -- | Encoded directly as a JSON number. -- @@ -81,7 +91,7 @@ -- "1" instance Aeson.ToJSON Int8 where toJSON int8 = int8 - & unpack + & #unpack & Aeson.toJSON @@ -90,7 +100,7 @@ -- >>> fromInt8 1 :: Int.Int8 -- 1 fromInt8 :: (Integral a) => Int8 -> a -fromInt8 int8 = fromIntegral (unpack int8) +fromInt8 int8 = fromIntegral (#unpack int8) -- | Converts any 'Integral' value into a 'Int8'. diff --git a/library/Octane/Type/KeyFrame.hs b/library/Octane/Type/KeyFrame.hs --- a/library/Octane/Type/KeyFrame.hs +++ b/library/Octane/Type/KeyFrame.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.KeyFrame (KeyFrame(..)) where @@ -8,6 +14,8 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.Float32 as Float32 import qualified Octane.Type.Word32 as Word32 @@ -15,20 +23,22 @@ -- | A key frame. data KeyFrame = KeyFrame - { time :: Float32.Float32 + { keyFrameTime :: Float32.Float32 -- ^ When this key frame occurred. - , frame :: Word32.Word32 + , keyFrameFrame :: Word32.Word32 -- ^ Which frame this key frame corresponds to. - , position :: Word32.Word32 + , keyFramePosition :: Word32.Word32 -- ^ The bit position of the start of this key frame in the network stream. } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''KeyFrame) + -- | Stored with the fields one after the other in order. -- -- >>> Binary.decode "\x00\x00\x00\x00\x01\x00\x00\x00\x02\x00\x00\x00" :: KeyFrame --- KeyFrame {time = 0.0, frame = 0x00000001, position = 0x00000002} +-- KeyFrame {keyFrameTime = 0.0, keyFrameFrame = 0x00000001, keyFramePosition = 0x00000002} -- --- >>> Binary.encode (KeyFrame { time = 0, frame = 1, position = 2 }) +-- >>> Binary.encode (KeyFrame 0 1 2) -- "\NUL\NUL\NUL\NUL\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL" instance Binary.Binary KeyFrame where get = KeyFrame @@ -37,8 +47,8 @@ <*> Binary.get put keyFrame = do - keyFrame & time & Binary.put - keyFrame & frame & Binary.put - keyFrame & position & Binary.put + keyFrame & #time & Binary.put + keyFrame & #frame & Binary.put + keyFrame & #position & Binary.put instance DeepSeq.NFData KeyFrame where diff --git a/library/Octane/Type/List.hs b/library/Octane/Type/List.hs --- a/library/Octane/Type/List.hs +++ b/library/Octane/Type/List.hs @@ -1,5 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Octane.Type.List (List(..)) where @@ -10,6 +15,8 @@ import qualified Control.Monad as Monad import qualified Data.Aeson as Aeson import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Exts as Exts import qualified GHC.Generics as Generics import qualified Octane.Type.Word32 as Word32 @@ -20,9 +27,11 @@ -- | A list of values. newtype List a = List - { unpack :: [a] + { listUnpack :: [a] } deriving (Eq, Generics.Generic, Ord) +$(OverloadedRecords.overloadedRecord Default.def ''List) + -- | Prefixed with the number of elements in the list. -- -- >>> Binary.decode "\x01\x00\x00\x00\x02" :: List Int8 @@ -37,8 +46,8 @@ elements & List & pure put list = do - list & unpack & length & fromIntegral & Word32.Word32 & Binary.put - list & unpack & mapM_ Binary.put + list & #unpack & length & fromIntegral & Word32.Word32 & Binary.put + list & #unpack & mapM_ Binary.put -- | Allows creating 'List' values with 'Exts.fromList'. Also allows 'List' -- literals with the @OverloadedLists@ extension. @@ -50,14 +59,14 @@ fromList items = List items - toList list = unpack list + toList list = #unpack list instance (DeepSeq.NFData a) => DeepSeq.NFData (List a) where -- | >>> show ([2] :: List Int) -- "fromList [2]" instance (Show a) => Show (List a) where - show list = "fromList " ++ show (unpack list) + show list = "fromList " ++ show (#unpack list) -- | Encoded as a JSON array directly. -- @@ -65,5 +74,5 @@ -- "[2]" instance (Aeson.ToJSON a) => Aeson.ToJSON (List a) where toJSON list = list - & unpack + & #unpack & Aeson.toJSON diff --git a/library/Octane/Type/Mark.hs b/library/Octane/Type/Mark.hs --- a/library/Octane/Type/Mark.hs +++ b/library/Octane/Type/Mark.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Mark (Mark(..)) where @@ -8,23 +14,27 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text import qualified Octane.Type.Word32 as Word32 -- | A tick mark on the replay. Both goals and saves make tick marks. data Mark = Mark - { label :: Text.Text + { markLabel :: Text.Text -- ^ The description of the tick mark. Typically something like -- @"Team0Goal"@ or @"Team1Save"@ or @"User"@. - , frame :: Word32.Word32 + , markFrame :: Word32.Word32 -- ^ Which frame this tick mark corresponds to. } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''Mark) + -- | Fields are stored one after the other in order. -- -- >>> Binary.decode "\x02\x00\x00\x00\x4b\x00\x01\x00\x00\x00" :: Mark --- Mark {label = "K", frame = 0x00000001} +-- Mark {markLabel = "K", markFrame = 0x00000001} -- -- >>> Binary.encode (Mark "K" 1) -- "\STX\NUL\NUL\NULK\NUL\SOH\NUL\NUL\NUL" @@ -34,7 +44,7 @@ <*> Binary.get put mark = do - mark & label & Binary.put - mark & frame & Binary.put + mark & #label & Binary.put + mark & #frame & Binary.put instance DeepSeq.NFData Mark diff --git a/library/Octane/Type/Message.hs b/library/Octane/Type/Message.hs --- a/library/Octane/Type/Message.hs +++ b/library/Octane/Type/Message.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Message (Message(..)) where @@ -8,24 +14,28 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text import qualified Octane.Type.Word32 as Word32 -- | A debugging message. Replays do not have any of these anymore. data Message = Message - { frame :: Word32.Word32 + { messageFrame :: Word32.Word32 -- ^ The frame this message corresponds to. - , name :: Text.Text + , messageName :: Text.Text -- ^ The primary player name. - , content :: Text.Text + , messageContent :: Text.Text -- ^ The actual content of the message. } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''Message) + -- | Fields stored in order, one after the other. -- -- >>> Binary.decode "\x01\x00\x00\x00\x02\x00\x00\x00\x41\x00\x02\x00\x00\x00\x42\x00" :: Message --- Message {frame = 0x00000001, name = "A", content = "B"} +-- Message {messageFrame = 0x00000001, messageName = "A", messageContent = "B"} -- -- >>> Binary.encode (Message 1 "A" "B") -- "\SOH\NUL\NUL\NUL\STX\NUL\NUL\NULA\NUL\STX\NUL\NUL\NULB\NUL" @@ -36,8 +46,8 @@ <*> Binary.get put message = do - message & frame & Binary.put - message & name & Binary.put - message & content & Binary.put + message & #frame & Binary.put + message & #name & Binary.put + message & #content & Binary.put instance DeepSeq.NFData Message where diff --git a/library/Octane/Type/OptimizedReplay.hs b/library/Octane/Type/OptimizedReplay.hs --- a/library/Octane/Type/OptimizedReplay.hs +++ b/library/Octane/Type/OptimizedReplay.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.OptimizedReplay ( OptimizedReplay(..) @@ -13,6 +19,8 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.CacheItem as CacheItem import qualified Octane.Type.ClassItem as ClassItem @@ -34,22 +42,24 @@ -- -- See 'Octane.Type.Replay.Replay'. data OptimizedReplay = OptimizedReplay - { version1 :: Word32.Word32 - , version2 :: Word32.Word32 - , label :: Text.Text - , properties :: Dictionary.Dictionary Property.Property - , levels :: List.List Text.Text - , keyFrames :: List.List KeyFrame.KeyFrame - , frames :: [Frame.Frame] - , messages :: List.List Message.Message - , marks :: List.List Mark.Mark - , packages :: List.List Text.Text - , objects :: List.List Text.Text - , names :: List.List Text.Text - , classes :: List.List ClassItem.ClassItem - , cache :: List.List CacheItem.CacheItem + { optimizedReplayVersion1 :: Word32.Word32 + , optimizedReplayVersion2 :: Word32.Word32 + , optimizedReplayLabel :: Text.Text + , optimizedReplayProperties :: Dictionary.Dictionary Property.Property + , optimizedReplayLevels :: List.List Text.Text + , optimizedReplayKeyFrames :: List.List KeyFrame.KeyFrame + , optimizedReplayFrames :: [Frame.Frame] + , optimizedReplayMessages :: List.List Message.Message + , optimizedReplayMarks :: List.List Mark.Mark + , optimizedReplayPackages :: List.List Text.Text + , optimizedReplayObjects :: List.List Text.Text + , optimizedReplayNames :: List.List Text.Text + , optimizedReplayClasses :: List.List ClassItem.ClassItem + , optimizedReplayCache :: List.List CacheItem.CacheItem } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''OptimizedReplay) + instance Binary.Binary OptimizedReplay where get = do replayWithFrames <- Binary.get @@ -66,41 +76,40 @@ -- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. fromReplayWithFrames :: (Monad m) => ReplayWithFrames.ReplayWithFrames -> m OptimizedReplay fromReplayWithFrames replayWithFrames = do - pure OptimizedReplay - { version1 = replayWithFrames & ReplayWithFrames.version1 - , version2 = replayWithFrames & ReplayWithFrames.version2 - , label = replayWithFrames & ReplayWithFrames.label - , properties = replayWithFrames & ReplayWithFrames.properties - , levels = replayWithFrames & ReplayWithFrames.levels - , keyFrames = replayWithFrames & ReplayWithFrames.keyFrames - , frames = replayWithFrames & ReplayWithFrames.frames & Optimizer.optimizeFrames - , messages = replayWithFrames & ReplayWithFrames.messages - , marks = replayWithFrames & ReplayWithFrames.marks - , packages = replayWithFrames & ReplayWithFrames.packages - , objects = replayWithFrames & ReplayWithFrames.objects - , names = replayWithFrames & ReplayWithFrames.names - , classes = replayWithFrames & ReplayWithFrames.classes - , cache = replayWithFrames & ReplayWithFrames.cache - } + let frames = replayWithFrames & #frames & Optimizer.optimizeFrames + pure (OptimizedReplay + (#version1 replayWithFrames) + (#version2 replayWithFrames) + (#label replayWithFrames) + (#properties replayWithFrames) + (#levels replayWithFrames) + (#keyFrames replayWithFrames) + frames + (#messages replayWithFrames) + (#marks replayWithFrames) + (#packages replayWithFrames) + (#objects replayWithFrames) + (#names replayWithFrames) + (#classes replayWithFrames) + (#cache replayWithFrames)) -- | Converts an 'OptimizedReplay' into a 'ReplayWithFrames.ReplayWithFrames'. -- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. toReplayWithFrames :: (Monad m) => OptimizedReplay -> m ReplayWithFrames.ReplayWithFrames toReplayWithFrames optimizedReplay = do - pure ReplayWithFrames.ReplayWithFrames - { ReplayWithFrames.version1 = optimizedReplay & version1 - , ReplayWithFrames.version2 = optimizedReplay & version2 - , ReplayWithFrames.label = optimizedReplay & label - , ReplayWithFrames.properties = optimizedReplay & properties - , ReplayWithFrames.levels = optimizedReplay & levels - , ReplayWithFrames.keyFrames = optimizedReplay & keyFrames - , ReplayWithFrames.frames = optimizedReplay & frames - , ReplayWithFrames.messages = optimizedReplay & messages - , ReplayWithFrames.marks = optimizedReplay & marks - , ReplayWithFrames.packages = optimizedReplay & packages - , ReplayWithFrames.objects = optimizedReplay & objects - , ReplayWithFrames.names = optimizedReplay & names - , ReplayWithFrames.classes = optimizedReplay & classes - , ReplayWithFrames.cache = optimizedReplay & cache - } + pure (ReplayWithFrames.ReplayWithFrames + (#version1 optimizedReplay) + (#version2 optimizedReplay) + (#label optimizedReplay) + (#properties optimizedReplay) + (#levels optimizedReplay) + (#keyFrames optimizedReplay) + (#frames optimizedReplay) + (#messages optimizedReplay) + (#marks optimizedReplay) + (#packages optimizedReplay) + (#objects optimizedReplay) + (#names optimizedReplay) + (#classes optimizedReplay) + (#cache optimizedReplay)) diff --git a/library/Octane/Type/Property.hs b/library/Octane/Type/Property.hs --- a/library/Octane/Type/Property.hs +++ b/library/Octane/Type/Property.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} @@ -21,6 +21,7 @@ import qualified Octane.Type.Word64 as Word64 +-- TODO: Split these into individual data types like RemoteId. -- | A metadata property. All properties have a size, but only some actually -- use it. The value stored in the property can be an array, a boolean, and -- so on. @@ -77,14 +78,14 @@ _ | kind == floatProperty -> do size <- Binary.get - value <- case Word64.unpack size of + value <- case #unpack size of 4 -> Binary.get x -> fail ("unknown FloatProperty size " ++ show x) value & FloatProperty size & pure _ | kind == intProperty -> do size <- Binary.get - value <- case Word64.unpack size of + value <- case #unpack size of 4 -> Binary.get x -> fail ("unknown IntProperty size " ++ show x) value & IntProperty size & pure @@ -96,7 +97,7 @@ _ | kind == qWordProperty -> do size <- Binary.get - value <- case Word64.unpack size of + value <- case #unpack size of 8 -> Binary.get x -> fail ("unknown QWordProperty size " ++ show x) value & QWordProperty size & pure @@ -106,7 +107,7 @@ value <- Binary.get value & StrProperty size & pure - _ -> fail ("unknown property type " ++ show (Text.unpack kind)) + _ -> fail ("unknown property type " ++ show (#unpack kind)) put property = case property of diff --git a/library/Octane/Type/RawReplay.hs b/library/Octane/Type/RawReplay.hs --- a/library/Octane/Type/RawReplay.hs +++ b/library/Octane/Type/RawReplay.hs @@ -1,12 +1,14 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -module Octane.Type.RawReplay - ( RawReplay(..) - , newRawReplay - ) where +module Octane.Type.RawReplay (RawReplay(..), newRawReplay) where import qualified Control.DeepSeq as DeepSeq import qualified Control.Monad as Monad @@ -14,6 +16,8 @@ import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Utility.CRC as CRC import qualified Octane.Type.Word32 as Word32 @@ -25,24 +29,26 @@ -- -- See 'Octane.Type.ReplayWithoutFrames.ReplayWithoutFrames'. data RawReplay = RawReplay - { headerSize :: Word32.Word32 + { rawReplayHeaderSize :: Word32.Word32 -- ^ The byte size of the first section. - , headerCRC :: Word32.Word32 + , rawReplayHeaderCRC :: Word32.Word32 -- ^ The CRC of the first section. - , header :: LazyBytes.ByteString + , rawReplayHeader :: LazyBytes.ByteString -- ^ The first section. - , contentSize :: Word32.Word32 + , rawReplayContentSize :: Word32.Word32 -- ^ The byte size of the second section. - , contentCRC :: Word32.Word32 + , rawReplayContentCRC :: Word32.Word32 -- ^ The CRC of the second section. - , content :: LazyBytes.ByteString + , rawReplayContent :: LazyBytes.ByteString -- ^ The second section. - , footer :: LazyBytes.ByteString + , rawReplayFooter :: LazyBytes.ByteString -- ^ Arbitrary data after the second section. In replays generated by -- Rocket League, this is always empty. However it is not technically -- invalid to put something here. } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''RawReplay) + -- | Decoding will fail if the CRCs don't match, but it is possible to encode -- invalid replays. That means @decode (encode rawReplay)@ can fail. instance Binary.Binary RawReplay where @@ -59,18 +65,18 @@ footer <- Binary.getRemainingLazyByteString - pure RawReplay { .. } + pure (RawReplay headerSize headerCRC header contentSize contentCRC content footer) put replay = do - Binary.put (headerSize replay) - Binary.put (headerCRC replay) - Binary.putLazyByteString (header replay) + Binary.put (#headerSize replay) + Binary.put (#headerCRC replay) + Binary.putLazyByteString (#header replay) - Binary.put (contentSize replay) - Binary.put (contentCRC replay) - Binary.putLazyByteString (content replay) + Binary.put (#contentSize replay) + Binary.put (#contentCRC replay) + Binary.putLazyByteString (#content replay) - Binary.putLazyByteString (footer replay) + Binary.putLazyByteString (#footer replay) instance DeepSeq.NFData RawReplay where @@ -89,7 +95,7 @@ let contentSize = Word32.toWord32 (LazyBytes.length content) let contentCRC = Word32.Word32 (CRC.crc32 content) - RawReplay { .. } + RawReplay headerSize headerCRC header contentSize contentCRC content footer checkCRC :: (Monad m) => Word32.Word32 -> LazyBytes.ByteString -> m () diff --git a/library/Octane/Type/RemoteId.hs b/library/Octane/Type/RemoteId.hs --- a/library/Octane/Type/RemoteId.hs +++ b/library/Octane/Type/RemoteId.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.RemoteId ( RemoteId(..) @@ -20,6 +26,8 @@ import qualified Data.Binary.Bits.Get as BinaryBit import qualified Data.Binary.Bits.Put as BinaryBit import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText import qualified Data.Text.Encoding as Encoding import qualified GHC.Generics as Generics @@ -33,50 +41,17 @@ -- >>> import qualified Data.Binary.Put as Binary --- | A player's canonical remote ID. This is the best way to uniquely identify --- players -data RemoteId - = RemotePlayStationId PlayStationId - | RemoteSplitscreenId SplitscreenId - | RemoteSteamId SteamId - | RemoteXboxId XboxId - deriving (Eq, Generics.Generic, Show) - -instance DeepSeq.NFData RemoteId where - --- | Encodes the remote ID as an object with "Type" and "Value" keys. --- --- >>> Aeson.encode (RemoteSteamId (SteamId 1)) --- "{\"Value\":1,\"Type\":\"Steam\"}" -instance Aeson.ToJSON RemoteId where - toJSON remoteId = case remoteId of - RemotePlayStationId x -> Aeson.object - [ "Type" .= ("PlayStation" :: Text.Text) - , "Value" .= Aeson.toJSON x - ] - RemoteSplitscreenId x -> Aeson.object - [ "Type" .= ("Splitscreen" :: Text.Text) - , "Value" .= Aeson.toJSON x - ] - RemoteSteamId x -> Aeson.object - [ "Type" .= ("Steam" :: Text.Text) - , "Value" .= Aeson.toJSON x - ] - RemoteXboxId x -> Aeson.object - [ "Type" .= ("Xbox" :: Text.Text) - , "Value" .= Aeson.toJSON x - ] - - data PlayStationId = PlayStationId - { playStationName :: Text.Text - , playStationUnknown :: LazyBytes.ByteString + { playStationIdName :: Text.Text + , playStationIdUnknown :: LazyBytes.ByteString } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''PlayStationId) + -- | Each part is stored as exactly 16 bits. -- -- >>> Binary.runGet (BinaryBit.runBitGet (BinaryBit.getBits 0)) "\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80" :: PlayStationId --- PlayStationId {playStationName = "B", playStationUnknown = "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH"} +-- PlayStationId {playStationIdName = "B", playStationIdUnknown = "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH"} -- -- >>> Binary.runPut (BinaryBit.runBitPut (BinaryBit.putBits 0 (PlayStationId "A" "\x01"))) -- "\130\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\128" @@ -98,8 +73,8 @@ putBits _ playStationId = do playStationId - & playStationName - & Text.unpack + & #name + & #unpack & StrictText.justifyLeft 16 '\x00' & StrictText.take 16 & Text.encodeLatin1 @@ -107,7 +82,7 @@ & BinaryBit.putByteString playStationId - & playStationUnknown + & #unknown & LazyBytes.toStrict & Endian.reverseBitsInStrictBytes & BinaryBit.putByteString @@ -118,9 +93,9 @@ -- "{\"Unknown\":\"0x42\",\"Name\":\"A\"}" instance Aeson.ToJSON PlayStationId where toJSON playStationId = Aeson.object - [ "Name" .= playStationName playStationId + [ "Name" .= #name playStationId , "Unknown" .= (playStationId - & playStationUnknown + & #unknown & LazyBytes.unpack & concatMap (Printf.printf "%02x") & ("0x" ++) @@ -129,13 +104,15 @@ newtype SplitscreenId = SplitscreenId - { unpackSplitscreenId :: Maybe Int + { splitscreenIdUnpack :: Maybe Int } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''SplitscreenId) + -- | Stored as a bare byte string. -- -- >>> Binary.runGet (BinaryBit.runBitGet (BinaryBit.getBits 0)) "\x00\x00\x00" :: SplitscreenId --- SplitscreenId {unpackSplitscreenId = Just 0} +-- SplitscreenId {splitscreenIdUnpack = Just 0} -- -- >>> Binary.runPut (BinaryBit.runBitPut (BinaryBit.putBits 0 (SplitscreenId (Just 0)))) -- "\NUL\NUL\NUL" @@ -161,17 +138,19 @@ -- >>> Aeson.encode (SplitscreenId (Just 0)) -- "0" instance Aeson.ToJSON SplitscreenId where - toJSON splitscreenId = splitscreenId & unpackSplitscreenId & Aeson.toJSON + toJSON splitscreenId = splitscreenId & #unpack & Aeson.toJSON newtype SteamId = SteamId - { unpackSteamId :: Word64.Word64 + { steamIdUnpack :: Word64.Word64 } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''SteamId) + -- | Stored as a plain 'Word64.Word64'. -- -- >>> Binary.runGet (BinaryBit.runBitGet (BinaryBit.getBits 0)) "\x80\x00\x00\x00\x00\x00\x00\x00" :: SteamId --- SteamId {unpackSteamId = 0x0000000000000001} +-- SteamId {steamIdUnpack = 0x0000000000000001} -- -- >>> Binary.runPut (BinaryBit.runBitPut (BinaryBit.putBits 0 (SteamId 1))) -- "\128\NUL\NUL\NUL\NUL\NUL\NUL\NUL" @@ -180,7 +159,7 @@ steamId <- BinaryBit.getBits 0 pure (SteamId steamId) - putBits _ steamId = steamId & unpackSteamId & BinaryBit.putBits 0 + putBits _ steamId = steamId & #unpack & BinaryBit.putBits 0 instance DeepSeq.NFData SteamId where @@ -189,17 +168,19 @@ -- >>> Aeson.encode (SteamId 1) -- "1" instance Aeson.ToJSON SteamId where - toJSON steamId = steamId & unpackSteamId & Aeson.toJSON + toJSON steamId = steamId & #unpack & Aeson.toJSON newtype XboxId = XboxId - { unpackXboxId :: Word64.Word64 + { xboxIdUnpack :: Word64.Word64 } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''XboxId) + -- | Stored as a plain 'Word64.Word64'. -- -- >>> Binary.runGet (BinaryBit.runBitGet (BinaryBit.getBits 0)) "\x80\x00\x00\x00\x00\x00\x00\x00" :: XboxId --- XboxId {unpackXboxId = 0x0000000000000001} +-- XboxId {xboxIdUnpack = 0x0000000000000001} -- -- >>> Binary.runPut (BinaryBit.runBitPut (BinaryBit.putBits 0 (XboxId 1))) -- "\128\NUL\NUL\NUL\NUL\NUL\NUL\NUL" @@ -208,7 +189,7 @@ xboxId <- BinaryBit.getBits 0 pure (XboxId xboxId) - putBits _ xboxId = xboxId & unpackXboxId & BinaryBit.putBits 0 + putBits _ xboxId = xboxId & #unpack & BinaryBit.putBits 0 instance DeepSeq.NFData XboxId where @@ -218,4 +199,39 @@ -- >>> Aeson.encode (XboxId 1) -- "1" instance Aeson.ToJSON XboxId where - toJSON xboxId = xboxId & unpackXboxId & Aeson.toJSON + toJSON xboxId = xboxId & #unpack & Aeson.toJSON + + +-- | A player's canonical remote ID. This is the best way to uniquely identify +-- players +data RemoteId + = RemotePlayStationId PlayStationId + | RemoteSplitscreenId SplitscreenId + | RemoteSteamId SteamId + | RemoteXboxId XboxId + deriving (Eq, Generics.Generic, Show) + +instance DeepSeq.NFData RemoteId where + +-- | Encodes the remote ID as an object with "Type" and "Value" keys. +-- +-- >>> Aeson.encode (RemoteSteamId (SteamId 1)) +-- "{\"Value\":1,\"Type\":\"Steam\"}" +instance Aeson.ToJSON RemoteId where + toJSON remoteId = case remoteId of + RemotePlayStationId x -> Aeson.object + [ "Type" .= ("PlayStation" :: Text.Text) + , "Value" .= Aeson.toJSON x + ] + RemoteSplitscreenId x -> Aeson.object + [ "Type" .= ("Splitscreen" :: Text.Text) + , "Value" .= Aeson.toJSON x + ] + RemoteSteamId x -> Aeson.object + [ "Type" .= ("Steam" :: Text.Text) + , "Value" .= Aeson.toJSON x + ] + RemoteXboxId x -> Aeson.object + [ "Type" .= ("Xbox" :: Text.Text) + , "Value" .= Aeson.toJSON x + ] diff --git a/library/Octane/Type/Replay.hs b/library/Octane/Type/Replay.hs --- a/library/Octane/Type/Replay.hs +++ b/library/Octane/Type/Replay.hs @@ -1,9 +1,19 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -module Octane.Type.Replay (Replay(..), fromOptimizedReplay, toOptimizedReplay) where +module Octane.Type.Replay + ( Replay(..) + , fromOptimizedReplay + , toOptimizedReplay + ) where import Data.Aeson ((.=)) import Data.Function ((&)) @@ -11,7 +21,9 @@ import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Binary as Binary -import qualified Data.Map as Map +import qualified Data.Default.Class as Default +import qualified Data.Map.Strict as Map +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText import qualified Data.Version as Version import qualified GHC.Generics as Generics @@ -31,8 +43,8 @@ -- to work with. It can be converted all the way back down to a -- 'Octane.Type.RawReplay.RawReplay' for serialization. data Replay = Replay - { version :: Version.Version - , metadata :: Map.Map StrictText.Text Property.Property + { replayVersion :: Version.Version + , replayMetadata :: Map.Map StrictText.Text Property.Property -- ^ High-level metadata about the replay. Only one key is actually -- required to be able to view the replay in Rocket League: -- @@ -72,13 +84,15 @@ -- team. This value is not validated, so you can put absurd values like -- @99@. To get an "unfair" team size like 1v4, you must set the -- @"bUnfairBots"@ 'Property.BoolProperty' to @True@. - , levels :: [StrictText.Text] - , messages :: Map.Map StrictText.Text StrictText.Text - , tickMarks :: Map.Map StrictText.Text StrictText.Text - , packages :: [StrictText.Text] - , frames :: [Frame.Frame] + , replayLevels :: [StrictText.Text] + , replayMessages :: Map.Map StrictText.Text StrictText.Text + , replayTickMarks :: Map.Map StrictText.Text StrictText.Text + , replayPackages :: [StrictText.Text] + , replayFrames :: [Frame.Frame] } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''Replay) + instance Binary.Binary Replay where get = do optimizedReplay <- Binary.get @@ -92,13 +106,13 @@ instance Aeson.ToJSON Replay where toJSON replay = Aeson.object - [ "Version" .= version replay - , "Metadata" .= metadata replay - , "Levels" .= levels replay - , "Messages" .= messages replay - , "TickMarks" .= tickMarks replay - , "Packages" .= packages replay - , "Frames" .= frames replay + [ "Version" .= #version replay + , "Metadata" .= #metadata replay + , "Levels" .= #levels replay + , "Messages" .= #messages replay + , "TickMarks" .= #tickMarks replay + , "Packages" .= #packages replay + , "Frames" .= #frames replay ] @@ -107,52 +121,52 @@ fromOptimizedReplay :: (Monad m) => OptimizedReplay.OptimizedReplay -> m Replay fromOptimizedReplay optimizedReplay = do pure Replay - { version = - [ OptimizedReplay.version1 optimizedReplay - , OptimizedReplay.version2 optimizedReplay + { replayVersion = + [ #version1 optimizedReplay + , #version2 optimizedReplay ] & map Word32.fromWord32 & Version.makeVersion - , metadata = optimizedReplay - & OptimizedReplay.properties - & Dictionary.unpack - & Map.mapKeys Text.unpack - , levels = optimizedReplay - & OptimizedReplay.levels - & List.unpack - & map Text.unpack - , messages = optimizedReplay - & OptimizedReplay.messages - & List.unpack + , replayMetadata = optimizedReplay + & #properties + & #unpack + & Map.mapKeys #unpack + , replayLevels = optimizedReplay + & #levels + & #unpack + & map #unpack + , replayMessages = optimizedReplay + & #messages + & #unpack & map (\ message -> do let key = message - & Message.frame - & Word32.unpack + & #frame + & #unpack & show & StrictText.pack let value = message - & Message.content - & Text.unpack + & #content + & #unpack (key, value)) & Map.fromList - , tickMarks = optimizedReplay - & OptimizedReplay.marks - & List.unpack + , replayTickMarks = optimizedReplay + & #marks + & #unpack & map (\ mark -> do let key = mark - & Mark.frame - & Word32.unpack + & #frame + & #unpack & show & StrictText.pack let value = mark - & Mark.label - & Text.unpack + & #label + & #unpack (key, value)) & Map.fromList - , packages = optimizedReplay - & OptimizedReplay.packages - & List.unpack - & map Text.unpack - , frames = optimizedReplay - & OptimizedReplay.frames + , replayPackages = optimizedReplay + & #packages + & #unpack + & map #unpack + , replayFrames = optimizedReplay + & #frames } @@ -161,54 +175,54 @@ toOptimizedReplay :: (Monad m) => Replay -> m OptimizedReplay.OptimizedReplay toOptimizedReplay replay = do let [version1, version2] = replay - & version + & #version & Version.versionBranch & map Word32.toWord32 -- Key frames aren't important for replays. Mark the first frame as a key -- frame and the rest as regular frames. let frames_ = replay - & frames + & #frames & zip [0 :: Int ..] - & map (\ (index, frame) -> frame { Frame.isKeyFrame = index == 0 }) + & map (\ (index, frame) -> frame { Frame.frameIsKeyFrame = index == 0 }) pure OptimizedReplay.OptimizedReplay - { OptimizedReplay.version1 = version1 - , OptimizedReplay.version2 = version2 - , OptimizedReplay.label = "TAGame.Replay_Soccar_TA" - , OptimizedReplay.properties = replay & metadata & Map.mapKeys Text.Text & Dictionary.Dictionary - , OptimizedReplay.levels = replay & levels & map Text.Text & List.List - , OptimizedReplay.keyFrames = frames_ - & filter Frame.isKeyFrame + { OptimizedReplay.optimizedReplayVersion1 = version1 + , OptimizedReplay.optimizedReplayVersion2 = version2 + , OptimizedReplay.optimizedReplayLabel = "TAGame.Replay_Soccar_TA" + , OptimizedReplay.optimizedReplayProperties = replay & #metadata & Map.mapKeys Text.Text & Dictionary.Dictionary + , OptimizedReplay.optimizedReplayLevels = replay & #levels & map Text.Text & List.List + , OptimizedReplay.optimizedReplayKeyFrames = frames_ + & filter #isKeyFrame & map (\ frame -> KeyFrame.KeyFrame - (Frame.time frame) - (frame & Frame.number & Word32.toWord32) + (#time frame) + (frame & #number & Word32.toWord32) 0) & List.List - , OptimizedReplay.frames = frames_ - , OptimizedReplay.messages = replay - & messages + , OptimizedReplay.optimizedReplayFrames = frames_ + , OptimizedReplay.optimizedReplayMessages = replay + & #messages & Map.toList & map (\ (key, value) -> do let frame = key & StrictText.unpack & read & Word32.Word32 let content = value & Text.Text Message.Message frame "" content) & List.List - , OptimizedReplay.marks = replay - & tickMarks + , OptimizedReplay.optimizedReplayMarks = replay + & #tickMarks & Map.toList & map (\ (key, value) -> do let label = value & Text.Text let frame = key & StrictText.unpack & read & Word32.Word32 Mark.Mark label frame) & List.List - , OptimizedReplay.packages = replay - & packages + , OptimizedReplay.optimizedReplayPackages = replay + & #packages & map Text.Text & List.List - , OptimizedReplay.objects = List.List [] -- TODO + , OptimizedReplay.optimizedReplayObjects = List.List [] -- TODO -- TODO: This list is usually empty. Also the parser doesn't use it at -- all. Is it safe for it to always be empty? - , OptimizedReplay.names = List.List [] - , OptimizedReplay.classes = List.List [] -- TODO - , OptimizedReplay.cache = List.List [] -- TODO + , OptimizedReplay.optimizedReplayNames = List.List [] + , OptimizedReplay.optimizedReplayClasses = List.List [] -- TODO + , OptimizedReplay.optimizedReplayCache = List.List [] -- TODO } diff --git a/library/Octane/Type/ReplayWithFrames.hs b/library/Octane/Type/ReplayWithFrames.hs --- a/library/Octane/Type/ReplayWithFrames.hs +++ b/library/Octane/Type/ReplayWithFrames.hs @@ -1,13 +1,23 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} - -module Octane.Type.ReplayWithFrames (ReplayWithFrames(..), fromReplayWithoutFrames, toReplayWithoutFrames) where +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -import Data.Function ((&)) +module Octane.Type.ReplayWithFrames + ( ReplayWithFrames(..) + , fromReplayWithoutFrames + , toReplayWithoutFrames + ) where import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.CacheItem as CacheItem import qualified Octane.Type.ClassItem as ClassItem @@ -30,22 +40,24 @@ -- -- See 'Octane.Type.OptimizedReplay.OptimizedReplay'. data ReplayWithFrames = ReplayWithFrames - { version1 :: Word32.Word32 - , version2 :: Word32.Word32 - , label :: Text.Text - , properties :: Dictionary.Dictionary Property.Property - , levels :: List.List Text.Text - , keyFrames :: List.List KeyFrame.KeyFrame - , frames :: [Frame.Frame] - , messages :: List.List Message.Message - , marks :: List.List Mark.Mark - , packages :: List.List Text.Text - , objects :: List.List Text.Text - , names :: List.List Text.Text - , classes :: List.List ClassItem.ClassItem - , cache :: List.List CacheItem.CacheItem + { replayWithFramesVersion1 :: Word32.Word32 + , replayWithFramesVersion2 :: Word32.Word32 + , replayWithFramesLabel :: Text.Text + , replayWithFramesProperties :: Dictionary.Dictionary Property.Property + , replayWithFramesLevels :: List.List Text.Text + , replayWithFramesKeyFrames :: List.List KeyFrame.KeyFrame + , replayWithFramesFrames :: [Frame.Frame] + , replayWithFramesMessages :: List.List Message.Message + , replayWithFramesMarks :: List.List Mark.Mark + , replayWithFramesPackages :: List.List Text.Text + , replayWithFramesObjects :: List.List Text.Text + , replayWithFramesNames :: List.List Text.Text + , replayWithFramesClasses :: List.List ClassItem.ClassItem + , replayWithFramesCache :: List.List CacheItem.CacheItem } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''ReplayWithFrames) + instance Binary.Binary ReplayWithFrames where get = do replayWithoutFrames <- Binary.get @@ -62,46 +74,45 @@ -- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. fromReplayWithoutFrames :: (Monad m) => ReplayWithoutFrames.ReplayWithoutFrames -> m ReplayWithFrames fromReplayWithoutFrames replayWithoutFrames = do - pure ReplayWithFrames - { version1 = replayWithoutFrames & ReplayWithoutFrames.version1 - , version2 = replayWithoutFrames & ReplayWithoutFrames.version2 - , label = replayWithoutFrames & ReplayWithoutFrames.label - , properties = replayWithoutFrames & ReplayWithoutFrames.properties - , levels = replayWithoutFrames & ReplayWithoutFrames.levels - , keyFrames = replayWithoutFrames & ReplayWithoutFrames.keyFrames - , frames = replayWithoutFrames & Parser.parseStream - , messages = replayWithoutFrames & ReplayWithoutFrames.messages - , marks = replayWithoutFrames & ReplayWithoutFrames.marks - , packages = replayWithoutFrames & ReplayWithoutFrames.packages - , objects = replayWithoutFrames & ReplayWithoutFrames.objects - , names = replayWithoutFrames & ReplayWithoutFrames.names - , classes = replayWithoutFrames & ReplayWithoutFrames.classes - , cache = replayWithoutFrames & ReplayWithoutFrames.cache - } + pure (ReplayWithFrames + (#version1 replayWithoutFrames) + (#version2 replayWithoutFrames) + (#label replayWithoutFrames) + (#properties replayWithoutFrames) + (#levels replayWithoutFrames) + (#keyFrames replayWithoutFrames) + (Parser.parseStream replayWithoutFrames) + (#messages replayWithoutFrames) + (#marks replayWithoutFrames) + (#packages replayWithoutFrames) + (#objects replayWithoutFrames) + (#names replayWithoutFrames) + (#classes replayWithoutFrames) + (#cache replayWithoutFrames)) -- | Converts a 'ReplayWithFrames' into a 'ReplayWithoutFrames.ReplayWithoutFrames'. -- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. toReplayWithoutFrames :: (Monad m) => ReplayWithFrames -> m ReplayWithoutFrames.ReplayWithoutFrames toReplayWithoutFrames replayWithFrames = do - pure ReplayWithoutFrames.ReplayWithoutFrames - { ReplayWithoutFrames.version1 = replayWithFrames & version1 - , ReplayWithoutFrames.version2 = replayWithFrames & version2 - , ReplayWithoutFrames.label = replayWithFrames & label - , ReplayWithoutFrames.properties = replayWithFrames & properties - , ReplayWithoutFrames.levels = replayWithFrames & levels - , ReplayWithoutFrames.keyFrames = replayWithFrames & keyFrames - , ReplayWithoutFrames.stream = Generator.generateStream - (replayWithFrames & frames) - (replayWithFrames & objects) - (replayWithFrames & names) - (replayWithFrames & classes) - (replayWithFrames & cache) - , ReplayWithoutFrames.messages = replayWithFrames & messages - , ReplayWithoutFrames.marks = replayWithFrames & marks - , ReplayWithoutFrames.packages = replayWithFrames & packages - , ReplayWithoutFrames.objects = replayWithFrames & objects - , ReplayWithoutFrames.names = replayWithFrames & names - , ReplayWithoutFrames.classes = replayWithFrames & classes - , ReplayWithoutFrames.cache = replayWithFrames & cache - } + let stream = Generator.generateStream + (#frames replayWithFrames) + (#objects replayWithFrames) + (#names replayWithFrames) + (#classes replayWithFrames) + (#cache replayWithFrames) + pure (ReplayWithoutFrames.ReplayWithoutFrames + (#version1 replayWithFrames) + (#version2 replayWithFrames) + (#label replayWithFrames) + (#properties replayWithFrames) + (#levels replayWithFrames) + (#keyFrames replayWithFrames) + stream + (#messages replayWithFrames) + (#marks replayWithFrames) + (#packages replayWithFrames) + (#objects replayWithFrames) + (#names replayWithFrames) + (#classes replayWithFrames) + (#cache replayWithFrames)) diff --git a/library/Octane/Type/ReplayWithoutFrames.hs b/library/Octane/Type/ReplayWithoutFrames.hs --- a/library/Octane/Type/ReplayWithoutFrames.hs +++ b/library/Octane/Type/ReplayWithoutFrames.hs @@ -1,15 +1,26 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -module Octane.Type.ReplayWithoutFrames (ReplayWithoutFrames(..), fromRawReplay, toRawReplay) where +module Octane.Type.ReplayWithoutFrames + ( ReplayWithoutFrames(..) + , fromRawReplay + , toRawReplay + ) where import qualified Control.DeepSeq as DeepSeq import qualified Data.Binary as Binary import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.CacheItem as CacheItem import qualified Octane.Type.ClassItem as ClassItem @@ -30,22 +41,24 @@ -- -- See 'Octane.Type.ReplayWithFrames.ReplayWithFrames'. data ReplayWithoutFrames = ReplayWithoutFrames - { version1 :: Word32.Word32 - , version2 :: Word32.Word32 - , label :: Text.Text - , properties :: Dictionary.Dictionary Property.Property - , levels :: List.List Text.Text - , keyFrames :: List.List KeyFrame.KeyFrame - , stream :: Stream.Stream - , messages :: List.List Message.Message - , marks :: List.List Mark.Mark - , packages :: List.List Text.Text - , objects :: List.List Text.Text - , names :: List.List Text.Text - , classes :: List.List ClassItem.ClassItem - , cache :: List.List CacheItem.CacheItem + { replayWithoutFramesVersion1 :: Word32.Word32 + , replayWithoutFramesVersion2 :: Word32.Word32 + , replayWithoutFramesLabel :: Text.Text + , replayWithoutFramesProperties :: Dictionary.Dictionary Property.Property + , replayWithoutFramesLevels :: List.List Text.Text + , replayWithoutFramesKeyFrames :: List.List KeyFrame.KeyFrame + , replayWithoutFramesStream :: Stream.Stream + , replayWithoutFramesMessages :: List.List Message.Message + , replayWithoutFramesMarks :: List.List Mark.Mark + , replayWithoutFramesPackages :: List.List Text.Text + , replayWithoutFramesObjects :: List.List Text.Text + , replayWithoutFramesNames :: List.List Text.Text + , replayWithoutFramesClasses :: List.List ClassItem.ClassItem + , replayWithoutFramesCache :: List.List CacheItem.CacheItem } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''ReplayWithoutFrames) + instance Binary.Binary ReplayWithoutFrames where get = do rawReplay <- Binary.get @@ -62,8 +75,8 @@ -- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. fromRawReplay :: (Monad m) => RawReplay.RawReplay -> m ReplayWithoutFrames fromRawReplay rawReplay = do - let header = RawReplay.header rawReplay - let content = RawReplay.content rawReplay + let header = #header rawReplay + let content = #content rawReplay let get = do version1 <- Binary.get @@ -81,7 +94,21 @@ classes <- Binary.get cache <- Binary.get - pure ReplayWithoutFrames { .. } + pure (ReplayWithoutFrames + version1 + version2 + label + properties + levels + keyFrames + stream + messages + marks + packages + objects + names + classes + cache) let bytes = LazyBytes.append header content pure (Binary.runGet get bytes) @@ -92,22 +119,22 @@ toRawReplay :: (Monad m) => ReplayWithoutFrames -> m RawReplay.RawReplay toRawReplay replay = do let header = Binary.runPut (do - Binary.put (version1 replay) - Binary.put (version2 replay) - Binary.put (label replay) - Binary.put (properties replay)) + Binary.put (#version1 replay) + Binary.put (#version2 replay) + Binary.put (#label replay) + Binary.put (#properties replay)) let content = Binary.runPut (do - Binary.put (levels replay) - Binary.put (keyFrames replay) - Binary.put (stream replay) - Binary.put (messages replay) - Binary.put (marks replay) - Binary.put (packages replay) - Binary.put (objects replay) - Binary.put (names replay) - Binary.put (classes replay) - Binary.put (cache replay)) + Binary.put (#levels replay) + Binary.put (#keyFrames replay) + Binary.put (#stream replay) + Binary.put (#messages replay) + Binary.put (#marks replay) + Binary.put (#packages replay) + Binary.put (#objects replay) + Binary.put (#names replay) + Binary.put (#classes replay) + Binary.put (#cache replay)) let footer = LazyBytes.empty diff --git a/library/Octane/Type/Replication.hs b/library/Octane/Type/Replication.hs --- a/library/Octane/Type/Replication.hs +++ b/library/Octane/Type/Replication.hs @@ -1,11 +1,18 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Replication (Replication(..)) where import qualified Control.DeepSeq as DeepSeq +import qualified Data.Default.Class as Default import qualified Data.Map.Strict as Map +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText import qualified GHC.Generics as Generics import qualified Octane.Type.CompressedWord as CompressedWord @@ -19,19 +26,21 @@ -- This cannot be an instance of 'Data.Binary.Bits.BinaryBit' because it -- requires out-of-band information (the class property map) to decode. data Replication = Replication - { actorId :: CompressedWord.CompressedWord + { replicationActorId :: CompressedWord.CompressedWord -- ^ The actor's ID. - , objectName :: StrictText.Text + , replicationObjectName :: StrictText.Text -- ^ The name of the actor's object. - , className :: StrictText.Text + , replicationClassName :: StrictText.Text -- ^ The name of the actor's class. - , state :: State.State + , replicationState :: State.State -- ^ Which state this actor's replication is in. - , initialization :: Maybe Initialization.Initialization + , replicationInitialization :: Maybe Initialization.Initialization -- ^ The optional initialization information for this actor. These only -- exist for new actors. - , properties :: Map.Map StrictText.Text Value.Value + , replicationProperties :: Map.Map StrictText.Text Value.Value -- ^ The property updates associated with this actor's replication. } deriving (Eq, Generics.Generic, Show) + +$(OverloadedRecords.overloadedRecord Default.def ''Replication) instance DeepSeq.NFData Replication where diff --git a/library/Octane/Type/Stream.hs b/library/Octane/Type/Stream.hs --- a/library/Octane/Type/Stream.hs +++ b/library/Octane/Type/Stream.hs @@ -1,5 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Stream (Stream(..)) where @@ -10,6 +16,8 @@ import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.Word32 as Word32 import qualified Octane.Utility.Endian as Endian @@ -18,9 +26,11 @@ -- | A stream of bits. newtype Stream = Stream - { unpack :: LazyBytes.ByteString + { streamUnpack :: LazyBytes.ByteString } deriving (Eq, Generics.Generic) +$(OverloadedRecords.overloadedRecord Default.def ''Stream) + -- | Prefixed by a length in bytes. Each byte is reversed such that -- @0b01234567@ is actually @0b76543210@. -- @@ -35,7 +45,7 @@ content <- size & Word32.fromWord32 & Binary.getLazyByteString content & Endian.reverseBitsInLazyBytes & Stream & pure put stream = do - let content = unpack stream + let content = #unpack stream content & LazyBytes.length & Word32.toWord32 & Binary.put content & Endian.reverseBitsInLazyBytes & Binary.putLazyByteString @@ -50,6 +60,6 @@ -- "Stream {unpack = \"2 bytes\"}" instance Show Stream where show stream = do - let size = stream & unpack & LazyBytes.length + let size = stream & #unpack & LazyBytes.length let s = if size == 1 then "" else "s" Printf.printf "Stream {unpack = \"%d byte%s\"}" size s diff --git a/library/Octane/Type/Text.hs b/library/Octane/Type/Text.hs --- a/library/Octane/Type/Text.hs +++ b/library/Octane/Type/Text.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Text (Text(..), encodeLatin1) where @@ -16,6 +22,8 @@ import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Char8 as StrictBytes import qualified Data.Char as Char +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.String as String import qualified Data.Text as StrictText import qualified Data.Text.Encoding as Encoding @@ -30,9 +38,11 @@ -- | A thin wrapper around 'StrictText.Text'. newtype Text = Text - { unpack :: StrictText.Text + { textUnpack :: StrictText.Text } deriving (Eq, Generics.Generic, Ord) +$(OverloadedRecords.overloadedRecord Default.def ''Text) + -- | Text is both length-prefixed and null-terminated. -- -- >>> Binary.decode "\x02\x00\x00\x00\x4b\x00" :: Text @@ -87,7 +97,7 @@ -- >>> show ("K" :: Text) -- "\"K\"" instance Show Text where - show text = show (unpack text) + show text = show (#unpack text) -- | Encoded directly as a JSON string. -- @@ -95,7 +105,7 @@ -- "\"K\"" instance Aeson.ToJSON Text where toJSON text = text - & unpack + & #unpack & Aeson.toJSON @@ -139,7 +149,7 @@ -> Text -> m () putText putInt putBytes convertBytes text = do - let fullText = text & unpack & flip StrictText.snoc '\NUL' + let fullText = text & #unpack & flip StrictText.snoc '\NUL' let size = fullText & StrictText.length & fromIntegral if StrictText.all Char.isLatin1 fullText then do diff --git a/library/Octane/Type/Value.hs b/library/Octane/Type/Value.hs --- a/library/Octane/Type/Value.hs +++ b/library/Octane/Type/Value.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE StrictData #-} module Octane.Type.Value (Value(..)) where @@ -19,6 +18,7 @@ import qualified Octane.Type.Word8 as Word8 +-- TODO: Split these into individual data types like RemoteId. -- | A replicated property's value. data Value = VBoolean diff --git a/library/Octane/Type/Vector.hs b/library/Octane/Type/Vector.hs --- a/library/Octane/Type/Vector.hs +++ b/library/Octane/Type/Vector.hs @@ -1,6 +1,13 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Vector ( Vector(..) @@ -17,6 +24,8 @@ import qualified Data.Binary.Bits as BinaryBit import qualified Data.Binary.Bits.Get as BinaryBit import qualified Data.Binary.Bits.Put as BinaryBit +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.CompressedWord as CompressedWord @@ -30,11 +39,13 @@ -- always serialized the same way. Sometimes it is three values run together, -- but other times it has a flag for the presence of each value. data Vector a = Vector - { x :: a - , y :: a - , z :: a + { vectorX :: a + , vectorY :: a + , vectorZ :: a } deriving (Eq, Generics.Generic, Show) +$(OverloadedRecords.overloadedRecord Default.def ''Vector) + instance (DeepSeq.NFData a) => DeepSeq.NFData (Vector a) where -- | Encoded as a JSON array with 3 elements. @@ -42,7 +53,7 @@ -- Aeson.encode (Vector 1 2 3 :: Vector Int) -- "[1,2,3]" instance (Aeson.ToJSON a) => Aeson.ToJSON (Vector a) where - toJSON vector = Aeson.toJSON [x vector, y vector, z vector] + toJSON vector = Aeson.toJSON [#x vector, #y vector, #z vector] -- | Gets a 'Vector' full of 'Float's. @@ -51,11 +62,11 @@ let maxValue = 1 let numBits = 16 - x' <- getFloat maxValue numBits - y' <- getFloat maxValue numBits - z' <- getFloat maxValue numBits + x <- getFloat maxValue numBits + y <- getFloat maxValue numBits + z <- getFloat maxValue numBits - pure Vector { x = x', y = y', z = z' } + pure (Vector x y z) getFloat :: Int -> Int -> BinaryBit.BitGet Float @@ -78,16 +89,16 @@ -- | Gets a 'Vector' full of 'Int8's. getInt8Vector :: BinaryBit.BitGet (Vector Int8.Int8) getInt8Vector = do - hasX <- BinaryBit.getBits 0 - x' <- if Boolean.unpack hasX then BinaryBit.getBits 0 else pure 0 + (hasX :: Boolean.Boolean) <- BinaryBit.getBits 0 + x <- if #unpack hasX then BinaryBit.getBits 0 else pure 0 - hasY <- BinaryBit.getBits 0 - y' <- if Boolean.unpack hasY then BinaryBit.getBits 0 else pure 0 + (hasY :: Boolean.Boolean) <- BinaryBit.getBits 0 + y <- if #unpack hasY then BinaryBit.getBits 0 else pure 0 - hasZ <- BinaryBit.getBits 0 - z' <- if Boolean.unpack hasZ then BinaryBit.getBits 0 else pure 0 + (hasZ :: Boolean.Boolean) <- BinaryBit.getBits 0 + z <- if #unpack hasZ then BinaryBit.getBits 0 else pure 0 - pure Vector { x = x' , y = y' , z = z' } + pure (Vector x y z) -- | Gets a 'Vector' full of 'Int's. @@ -102,16 +113,16 @@ dy <- fmap CompressedWord.fromCompressedWord (BinaryBit.getBits maxValue) dz <- fmap CompressedWord.fromCompressedWord (BinaryBit.getBits maxValue) - pure Vector { x = dx - bias , y = dy - bias , z = dz - bias } + pure (Vector (dx - bias) (dy - bias) (dz - bias)) -- | Puts a 'Vector' full of 'Int8's. putInt8Vector :: Vector Int8.Int8 -> BinaryBit.BitPut () putInt8Vector _ = do - pure () + pure () -- TODO -- | Puts a 'Vector' full of 'Int's. putIntVector :: Vector Int -> BinaryBit.BitPut () putIntVector _ = do - pure () + pure () -- TODO diff --git a/library/Octane/Type/Word16.hs b/library/Octane/Type/Word16.hs --- a/library/Octane/Type/Word16.hs +++ b/library/Octane/Type/Word16.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Word16 (Word16(..), fromWord16, toWord16) where @@ -11,6 +17,8 @@ import qualified Data.Binary as Binary import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Word as Word import qualified GHC.Generics as Generics import qualified Text.Printf as Printf @@ -18,9 +26,11 @@ -- | A 16-bit unsigned integer. newtype Word16 = Word16 - { unpack :: Word.Word16 + { word16Unpack :: Word.Word16 } deriving (Eq, Generics.Generic, Num, Ord) +$(OverloadedRecords.overloadedRecord Default.def ''Word16) + -- | Little-endian. -- -- >>> Binary.decode "\x01\x00" :: Word16 @@ -34,7 +44,7 @@ pure (Word16 value) put word16 = do - let value = unpack word16 + let value = #unpack word16 Binary.putWord16le value instance DeepSeq.NFData Word16 where @@ -44,7 +54,7 @@ -- >>> show (1 :: Word16) -- "0x0001" instance Show Word16 where - show word16 = Printf.printf "0x%04x" (unpack word16) + show word16 = Printf.printf "0x%04x" (#unpack word16) -- | Encoded as a JSON number. -- @@ -52,7 +62,7 @@ -- "1" instance Aeson.ToJSON Word16 where toJSON word16 = word16 - & unpack + & #unpack & Aeson.toJSON @@ -64,7 +74,7 @@ -- >>> fromWord16 0xffff :: Data.Int.Int16 -- -1 fromWord16 :: (Integral a) => Word16 -> a -fromWord16 word16 = fromIntegral (unpack word16) +fromWord16 word16 = fromIntegral (#unpack word16) -- | Converts any 'Integral' value into a 'Word16'. diff --git a/library/Octane/Type/Word32.hs b/library/Octane/Type/Word32.hs --- a/library/Octane/Type/Word32.hs +++ b/library/Octane/Type/Word32.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Word32 (Word32(..), fromWord32, toWord32) where @@ -15,6 +21,8 @@ import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Word as Word import qualified GHC.Generics as Generics import qualified Octane.Utility.Endian as Endian @@ -27,9 +35,11 @@ -- | A 32-bit unsigned integer. newtype Word32 = Word32 - { unpack :: Word.Word32 + { word32Unpack :: Word.Word32 } deriving (Eq, Generics.Generic, Num, Ord) +$(OverloadedRecords.overloadedRecord Default.def ''Word32) + -- | Little-endian. -- -- >>> Binary.decode "\x01\x00\x00\x00" :: Word32 @@ -43,7 +53,7 @@ pure (Word32 value) put word32 = do - let value = unpack word32 + let value = #unpack word32 Binary.putWord32le value -- | Little-endian with the bits in each byte reversed. @@ -76,7 +86,7 @@ -- >>> show (1 :: Word32) -- "0x00000001" instance Show Word32 where - show word32 = Printf.printf "0x%08x" (unpack word32) + show word32 = Printf.printf "0x%08x" (#unpack word32) -- | Encoded as a JSON number. -- @@ -84,7 +94,7 @@ -- "1" instance Aeson.ToJSON Word32 where toJSON word32 = word32 - & unpack + & #unpack & Aeson.toJSON @@ -96,7 +106,7 @@ -- >>> fromWord32 0xffffffff :: Data.Int.Int32 -- -1 fromWord32 :: (Integral a) => Word32 -> a -fromWord32 word32 = fromIntegral (unpack word32) +fromWord32 word32 = fromIntegral (#unpack word32) -- | Converts any 'Integral' value into a 'Word32'. diff --git a/library/Octane/Type/Word64.hs b/library/Octane/Type/Word64.hs --- a/library/Octane/Type/Word64.hs +++ b/library/Octane/Type/Word64.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Word64 (Word64(..), fromWord64, toWord64) where @@ -15,6 +21,8 @@ import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Word as Word import qualified GHC.Generics as Generics import qualified Octane.Utility.Endian as Endian @@ -27,9 +35,11 @@ -- | A 64-bit unsigned integer. newtype Word64 = Word64 - { unpack :: Word.Word64 + { word64Unpack :: Word.Word64 } deriving (Eq, Generics.Generic, Num, Ord) +$(OverloadedRecords.overloadedRecord Default.def ''Word64) + -- | Little-endian. -- -- >>> Binary.decode "\x01\x00\x00\x00\x00\x00\x00\x00" :: Word64 @@ -43,7 +53,7 @@ pure (Word64 value) put word64 = do - let value = unpack word64 + let value = #unpack word64 Binary.putWord64le value -- | Little-endian with the bits in each byte reversed. @@ -76,7 +86,7 @@ -- >>> show (1 :: Word64) -- "0x0000000000000001" instance Show Word64 where - show word64 = Printf.printf "0x%016x" (unpack word64) + show word64 = Printf.printf "0x%016x" (#unpack word64) -- | Encoded as a JSON number. -- @@ -84,7 +94,7 @@ -- "1" instance Aeson.ToJSON Word64 where toJSON word64 = word64 - & unpack + & #unpack & Aeson.toJSON @@ -96,7 +106,7 @@ -- >>> fromWord64 0xffffffffffffffff :: Data.Int.Int64 -- -1 fromWord64 :: (Integral a) => Word64 -> a -fromWord64 word64 = fromIntegral (unpack word64) +fromWord64 word64 = fromIntegral (#unpack word64) -- | Converts any 'Integral' value into a 'Word64'. diff --git a/library/Octane/Type/Word8.hs b/library/Octane/Type/Word8.hs --- a/library/Octane/Type/Word8.hs +++ b/library/Octane/Type/Word8.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Type.Word8 (Word8(..), fromWord8, toWord8) where @@ -15,6 +21,8 @@ import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Lazy as LazyBytes +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Word as Word import qualified GHC.Generics as Generics import qualified Octane.Utility.Endian as Endian @@ -27,9 +35,11 @@ -- | A 8-bit unsigned integer. newtype Word8 = Word8 - { unpack :: Word.Word8 + { word8Unpack :: Word.Word8 } deriving (Eq, Generics.Generic, Num, Ord) +$(OverloadedRecords.overloadedRecord Default.def ''Word8) + -- | >>> Binary.decode "\x01" :: Word8 -- 0x01 -- @@ -41,7 +51,7 @@ pure (Word8 value) put word8 = do - let value = unpack word8 + let value = #unpack word8 Binary.putWord8 value -- | The bits are reversed. @@ -74,7 +84,7 @@ -- >>> show (1 :: Word8) -- "0x01" instance Show Word8 where - show word8 = Printf.printf "0x%02x" (unpack word8) + show word8 = Printf.printf "0x%02x" (#unpack word8) -- | Encoded as a JSON number. -- @@ -82,7 +92,7 @@ -- "1" instance Aeson.ToJSON Word8 where toJSON word8 = word8 - & unpack + & #unpack & Aeson.toJSON @@ -94,7 +104,7 @@ -- >>> fromWord8 0xff :: Data.Int.Int8 -- -1 fromWord8 :: (Integral a) => Word8 -> a -fromWord8 word8 = fromIntegral (unpack word8) +fromWord8 word8 = fromIntegral (#unpack word8) -- | Converts any 'Integral' value into a 'Word8'. diff --git a/library/Octane/Utility/ClassPropertyMap.hs b/library/Octane/Utility/ClassPropertyMap.hs --- a/library/Octane/Utility/ClassPropertyMap.hs +++ b/library/Octane/Utility/ClassPropertyMap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PackageImports #-} -- | This module is responsible for building the class property map, which maps @@ -17,12 +18,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe import qualified Data.Text as StrictText -import qualified Octane.Type.CacheItem as CacheItem -import qualified Octane.Type.CacheProperty as CacheProperty -import qualified Octane.Type.ClassItem as ClassItem -import qualified Octane.Type.List as List import qualified Octane.Type.ReplayWithoutFrames as ReplayWithoutFrames -import qualified Octane.Type.Text as Text import qualified Octane.Type.Word32 as Word32 import qualified "regex-compat" Text.Regex as Regex @@ -56,12 +52,12 @@ -- ID, the second is its cache ID, and the third is its parent's cache ID. getClassCache :: ReplayWithoutFrames.ReplayWithoutFrames -> [(Int, Int, Int)] getClassCache replay = replay - & ReplayWithoutFrames.cache - & List.unpack + & #cache + & #unpack & map (\ x -> - ( x & CacheItem.classId & Word32.fromWord32 - , x & CacheItem.cacheId & Word32.fromWord32 - , x & CacheItem.parentCacheId & Word32.fromWord32 + ( x & #classId & Word32.fromWord32 + , x & #cacheId & Word32.fromWord32 + , x & #parentCacheId & Word32.fromWord32 )) @@ -125,9 +121,9 @@ -- | The property map is a mapping from property IDs to property names. getPropertyMap :: ReplayWithoutFrames.ReplayWithoutFrames -> IntMap.IntMap StrictText.Text getPropertyMap replay = replay - & ReplayWithoutFrames.objects - & List.unpack - & map Text.unpack + & #objects + & #unpack + & map #unpack & zip [0 ..] & IntMap.fromList @@ -139,16 +135,16 @@ getBasicClassPropertyMap replay = let propertyMap = getPropertyMap replay in replay - & ReplayWithoutFrames.cache - & List.unpack + & #cache + & #unpack & map (\ x -> let - classId = x & CacheItem.classId & Word32.fromWord32 + classId = x & #classId & Word32.fromWord32 properties = x - & CacheItem.properties - & List.unpack + & #properties + & #unpack & Maybe.mapMaybe (\ y -> let - streamId = y & CacheProperty.streamId & Word32.fromWord32 - propertyId = y & CacheProperty.objectId & Word32.fromWord32 + streamId = y & #streamId & Word32.fromWord32 + propertyId = y & #objectId & Word32.fromWord32 in case IntMap.lookup propertyId propertyMap of Nothing -> Nothing Just name -> Just (streamId, name)) @@ -160,11 +156,11 @@ -- | The actor map is a mapping from class names to their IDs. getActorMap :: ReplayWithoutFrames.ReplayWithoutFrames -> Map.Map StrictText.Text Int getActorMap replay = replay - & ReplayWithoutFrames.classes - & List.unpack + & #classes + & #unpack & map (\ x -> let - className = x & ClassItem.name & Text.unpack - classId = x & ClassItem.streamId & Word32.fromWord32 + className = x & #name & #unpack + classId = x & #streamId & Word32.fromWord32 in (className, classId)) & Map.fromList diff --git a/library/Octane/Utility/Generator.hs b/library/Octane/Utility/Generator.hs --- a/library/Octane/Utility/Generator.hs +++ b/library/Octane/Utility/Generator.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedLabels #-} + module Octane.Utility.Generator (generateStream) where import Data.Function ((&)) @@ -43,9 +45,9 @@ putFrame :: Frame.Frame -> BinaryBit.BitPut () putFrame frame = do - frame & Frame.time & BinaryBit.putBits 32 - frame & Frame.delta & BinaryBit.putBits 32 - frame & Frame.replications & putReplications + frame & #time & BinaryBit.putBits 32 + frame & #delta & BinaryBit.putBits 32 + frame & #replications & putReplications putReplications :: [Replication.Replication] -> BinaryBit.BitPut () @@ -61,8 +63,8 @@ putReplication :: Replication.Replication -> BinaryBit.BitPut () putReplication replication = do - replication & Replication.actorId & BinaryBit.putBits 0 - case Replication.state replication of + replication & #actorId & BinaryBit.putBits 0 + case #state replication of State.SOpening -> putNewReplication replication State.SExisting -> putExistingReplication replication State.SClosing -> putClosedReplication replication @@ -74,7 +76,7 @@ True & Boolean.Boolean & BinaryBit.putBits 1 -- new False & Boolean.Boolean & BinaryBit.putBits 1 -- unknown -- TODO: convert object name into ID and put it - case Replication.initialization replication of + case #initialization replication of Nothing -> pure () Just x -> Initialization.putInitialization x diff --git a/library/Octane/Utility/Optimizer.hs b/library/Octane/Utility/Optimizer.hs --- a/library/Octane/Utility/Optimizer.hs +++ b/library/Octane/Utility/Optimizer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} module Octane.Utility.Optimizer (optimizeFrames) where @@ -39,11 +40,11 @@ updateState :: Frame.Frame -> State -> State updateState frame state1 = let spawned = frame - & Frame.replications + & #replications & filter (\ replication -> replication - & Replication.state + & #state & (== State.SOpening)) - & map Replication.actorId + & map #actorId & map CompressedWord.fromCompressedWord state2 = spawned & foldr @@ -53,11 +54,11 @@ state1 destroyed = frame - & Frame.replications + & #replications & filter (\ replication -> replication - & Replication.state + & #state & (== State.SClosing)) - & map Replication.actorId + & map #actorId & map CompressedWord.fromCompressedWord state3 = destroyed & foldr @@ -67,23 +68,23 @@ state2 updated = frame - & Frame.replications + & #replications & filter (\ replication -> replication - & Replication.state + & #state & (== State.SExisting)) state4 = updated & foldr (\ replication -> IntMap.alter (\ maybeValue -> Just (case maybeValue of Nothing -> - (True, Replication.properties replication) + (True, #properties replication) Just (alive, properties) -> ( alive , Map.union - (Replication.properties replication) + (#properties replication) properties ))) - (replication & Replication.actorId & CompressedWord.fromCompressedWord)) + (replication & #actorId & CompressedWord.fromCompressedWord)) state3 in state4 @@ -92,31 +93,31 @@ getDelta :: State -> Frame.Frame -> Frame.Frame getDelta state frame = let newReplications = frame - & Frame.replications + & #replications -- Remove replications that aren't actually new. & reject (\ replication -> let - isOpening = Replication.state replication == State.SOpening - actorId = Replication.actorId replication + isOpening = #state replication == State.SOpening + actorId = #actorId replication currentState = IntMap.lookup (CompressedWord.fromCompressedWord actorId) state isAlive = fmap fst currentState wasAlreadyAlive = isAlive == Just True in isOpening && wasAlreadyAlive) -- Remove properties that haven't changed. & map (\ replication -> - if Replication.state replication == State.SExisting + if #state replication == State.SExisting then let - actorId = Replication.actorId replication + actorId = #actorId replication currentState = IntMap.findWithDefault (True, Map.empty) (CompressedWord.fromCompressedWord actorId) state currentProperties = snd currentState - newProperties = Replication.properties replication + newProperties = #properties replication changes = newProperties & Map.filterWithKey (\ name newValue -> let oldValue = Map.lookup name currentProperties in Just newValue /= oldValue) - in replication { Replication.properties = changes } + in replication { Replication.replicationProperties = changes } else replication) - in frame { Frame.replications = newReplications } + in frame { Frame.frameReplications = newReplications } reject :: (a -> Bool) -> [a] -> [a] diff --git a/library/Octane/Utility/Parser.hs b/library/Octane/Utility/Parser.hs --- a/library/Octane/Utility/Parser.hs +++ b/library/Octane/Utility/Parser.hs @@ -1,6 +1,13 @@ {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Octane.Utility.Parser (parseStream) where @@ -9,10 +16,12 @@ import qualified Control.DeepSeq as DeepSeq import qualified Control.Monad as Monad import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as Bits +import qualified Data.Binary.Bits.Get as BinaryBit import qualified Data.Binary.Get as Binary +import qualified Data.Default.Class as Default import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map +import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Set as Set import qualified Data.Text as StrictText import qualified Data.Version as Version @@ -20,19 +29,15 @@ import qualified Octane.Data as Data import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.CompressedWord as CompressedWord -import qualified Octane.Type.Dictionary as Dictionary import qualified Octane.Type.Float32 as Float32 import qualified Octane.Type.Frame as Frame import qualified Octane.Type.Initialization as Initialization import qualified Octane.Type.Int32 as Int32 -import qualified Octane.Type.KeyFrame as KeyFrame -import qualified Octane.Type.List as List import qualified Octane.Type.Property as Property import qualified Octane.Type.RemoteId as RemoteId import qualified Octane.Type.ReplayWithoutFrames as ReplayWithoutFrames import qualified Octane.Type.Replication as Replication import qualified Octane.Type.State as State -import qualified Octane.Type.Stream as Stream import qualified Octane.Type.Text as Text import qualified Octane.Type.Value as Value import qualified Octane.Type.Vector as Vector @@ -44,28 +49,92 @@ import qualified Text.Printf as Printf +-- Data types + + +-- { class stream id => { property stream id => name } } +type ClassPropertyMap = IntMap.IntMap (IntMap.IntMap StrictText.Text) + + +-- { stream id => object name } +type ObjectMap = IntMap.IntMap StrictText.Text + + +-- { class name => class id } +type ClassMap = Map.Map StrictText.Text Int + + +data Thing = Thing + { thingFlag :: Boolean.Boolean + , thingObjectId :: Int32.Int32 + , thingObjectName :: StrictText.Text + , thingClassId :: Int + , thingClassName :: StrictText.Text + , thingInitialization :: Initialization.Initialization + } deriving (Eq, Generics.Generic, Show) + +$(OverloadedRecords.overloadedRecord Default.def ''Thing) + +instance DeepSeq.NFData Thing + + +data Context = Context + { contextObjectMap :: ObjectMap + , contextClassPropertyMap :: ClassPropertyMap + , contextThings :: IntMap.IntMap Thing + , contextClassMap :: ClassMap + , contextKeyFrames :: Set.Set Word + , contextVersion :: Version.Version + } deriving (Eq, Generics.Generic, Show) + +$(OverloadedRecords.overloadedRecord Default.def ''Context) + +instance DeepSeq.NFData Context + + +extractContext :: ReplayWithoutFrames.ReplayWithoutFrames -> Context +extractContext replay = do + let keyFrames = replay + & #keyFrames + & #unpack + & map #frame + & map Word32.fromWord32 + & Set.fromList + let version = + [ replay & #version1 + , replay & #version2 + ] & map Word32.fromWord32 & Version.makeVersion + Context + (CPM.getPropertyMap replay) + (CPM.getClassPropertyMap replay) + IntMap.empty + (CPM.getActorMap replay) + keyFrames + version + + -- | Parses the network stream and returns a list of frames. parseStream :: ReplayWithoutFrames.ReplayWithoutFrames -> [Frame.Frame] parseStream replay = let numFrames = replay - & ReplayWithoutFrames.properties - & Dictionary.unpack + & #properties + & #unpack & Map.lookup ("NumFrames" & StrictText.pack & Text.Text) & (\ property -> case property of - Just (Property.IntProperty _ x) -> x & Int32.unpack & fromIntegral + Just (Property.IntProperty _ x) -> x & #unpack & fromIntegral _ -> 0) - get = replay & extractContext & getFrames 0 numFrames & Bits.runBitGet - stream = replay & ReplayWithoutFrames.stream & Stream.unpack + get = replay & extractContext & getFrames 0 numFrames & BinaryBit.runBitGet + stream = replay & #stream & #unpack (_context, frames) = Binary.runGet get stream in frames -getFrames :: Word -> Int -> Context -> Bits.BitGet (Context, [Frame.Frame]) +getFrames :: Word -> Int -> Context -> BinaryBit.BitGet (Context, [Frame.Frame]) getFrames number numFrames context = do if fromIntegral number >= numFrames then pure (context, []) else do - isEmpty <- Bits.isEmpty + isEmpty <- BinaryBit.isEmpty if isEmpty then pure (context, []) else do @@ -77,7 +146,7 @@ pure (newerContext, (frame : frames)) -getMaybeFrame :: Context -> Word -> Bits.BitGet (Maybe (Context, Frame.Frame)) +getMaybeFrame :: Context -> Word -> BinaryBit.BitGet (Maybe (Context, Frame.Frame)) getMaybeFrame context number = do time <- getFloat32 delta <- getFloat32 @@ -90,21 +159,19 @@ pure (Just (newContext, frame)) -getFrame :: Context -> Word -> Float32.Float32 -> Float32.Float32 -> Bits.BitGet (Context, Frame.Frame) +getFrame :: Context -> Word -> Float32.Float32 -> Float32.Float32 -> BinaryBit.BitGet (Context, Frame.Frame) getFrame context number time delta = do (newContext, replications) <- getReplications context - let frame = - Frame.Frame - { Frame.number = number - , Frame.isKeyFrame = context & contextKeyFrames & Set.member number - , Frame.time = time - , Frame.delta = delta - , Frame.replications = replications - } + let frame = Frame.Frame + number + (context & #keyFrames & Set.member number) + time + delta + replications (newContext, frame) & DeepSeq.force & pure -getReplications :: Context -> Bits.BitGet (Context, [Replication.Replication]) +getReplications :: Context -> BinaryBit.BitGet (Context, [Replication.Replication]) getReplications context = do maybeReplication <- getMaybeReplication context case maybeReplication of @@ -114,22 +181,22 @@ pure (newerContext, replication : replications) -getMaybeReplication :: Context -> Bits.BitGet (Maybe (Context, Replication.Replication)) +getMaybeReplication :: Context -> BinaryBit.BitGet (Maybe (Context, Replication.Replication)) getMaybeReplication context = do hasReplication <- getBool - if Boolean.unpack hasReplication + if #unpack hasReplication then do (newContext,replication) <- getReplication context pure (Just (newContext, replication)) else pure Nothing -getReplication :: Context -> Bits.BitGet (Context, Replication.Replication) +getReplication :: Context -> BinaryBit.BitGet (Context, Replication.Replication) getReplication context = do actorId <- BinaryBit.getBits maxActorId isOpen <- getBool let go = - if Boolean.unpack isOpen + if #unpack isOpen then getOpenReplication else getClosedReplication go context actorId @@ -137,11 +204,11 @@ getOpenReplication :: Context -> CompressedWord.CompressedWord - -> Bits.BitGet (Context, Replication.Replication) + -> BinaryBit.BitGet (Context, Replication.Replication) getOpenReplication context actorId = do isNew <- getBool let go = - if Boolean.unpack isNew + if #unpack isNew then getNewReplication else getExistingReplication go context actorId @@ -149,85 +216,77 @@ getNewReplication :: Context -> CompressedWord.CompressedWord - -> Bits.BitGet (Context, Replication.Replication) + -> BinaryBit.BitGet (Context, Replication.Replication) getNewReplication context actorId = do unknownFlag <- getBool - if Boolean.unpack unknownFlag + if #unpack unknownFlag then fail "the unknown flag in a new replication is true! what does it mean?" else pure () objectId <- getInt32 - objectName <- case context & contextObjectMap & IntMap.lookup (Int32.fromInt32 objectId) of + objectName <- case context & #objectMap & IntMap.lookup (Int32.fromInt32 objectId) of Nothing -> fail ("could not find object name for id " ++ show objectId) Just x -> pure x (classId, className) <- CPM.getClass - (contextObjectMap context) + (#objectMap context) Data.classes - (contextClassMap context) + (#classMap context) (Int32.fromInt32 objectId) classInit <- Initialization.getInitialization className let thing = Thing - { thingFlag = unknownFlag - , thingObjectId = objectId - , thingObjectName = objectName - , thingClassId = classId - , thingClassName = className - , thingInitialization = classInit - } - let things = contextThings context + unknownFlag + objectId + objectName + classId + className + classInit + let things = #things context let newThings = IntMap.insert (CompressedWord.fromCompressedWord actorId) thing things let newContext = context { contextThings = newThings } - pure - ( newContext - , Replication.Replication - { Replication.actorId = actorId - , Replication.objectName = objectName - , Replication.className = className - , Replication.state = State.SOpening - , Replication.initialization = Just classInit - , Replication.properties = Map.empty - }) + pure (newContext, Replication.Replication + actorId + objectName + className + State.SOpening + (Just classInit) + Map.empty) getExistingReplication :: Context -> CompressedWord.CompressedWord - -> Bits.BitGet (Context, Replication.Replication) + -> BinaryBit.BitGet (Context, Replication.Replication) getExistingReplication context actorId = do - thing <- case context & contextThings & IntMap.lookup (CompressedWord.fromCompressedWord actorId) of + thing <- case context & #things & IntMap.lookup (CompressedWord.fromCompressedWord actorId) of Nothing -> fail ("could not find thing for existing actor " ++ show actorId) Just x -> pure x props <- getProps context thing pure (context, Replication.Replication - { Replication.actorId = actorId - , Replication.objectName = thingObjectName thing - , Replication.className = thingClassName thing - , Replication.state = State.SExisting - , Replication.initialization = Nothing - , Replication.properties = props - }) + actorId + (#objectName thing) + (#className thing) + State.SExisting + Nothing + props) getClosedReplication :: Context -> CompressedWord.CompressedWord - -> Bits.BitGet (Context, Replication.Replication) + -> BinaryBit.BitGet (Context, Replication.Replication) getClosedReplication context actorId = do - thing <- case context & contextThings & IntMap.lookup (CompressedWord.fromCompressedWord actorId) of + thing <- case context & #things & IntMap.lookup (CompressedWord.fromCompressedWord actorId) of Nothing -> fail ("could not find thing for closed actor " ++ show actorId) Just x -> pure x - let newThings = context & contextThings & IntMap.delete (CompressedWord.fromCompressedWord actorId) + let newThings = context & #things & IntMap.delete (CompressedWord.fromCompressedWord actorId) let newContext = context { contextThings = newThings } - pure - ( newContext - , Replication.Replication - { Replication.actorId = actorId - , Replication.objectName = thingObjectName thing - , Replication.className = thingClassName thing - , Replication.state = State.SClosing - , Replication.initialization = Nothing - , Replication.properties = Map.empty - }) + pure (newContext, Replication.Replication + actorId + (#objectName thing) + (#className thing) + State.SClosing + Nothing + Map.empty) -getProps :: Context -> Thing -> Bits.BitGet (Map.Map StrictText.Text Value.Value) +getProps :: Context -> Thing -> BinaryBit.BitGet (Map.Map StrictText.Text Value.Value) getProps context thing = do maybeProp <- getMaybeProp context thing case maybeProp of @@ -238,20 +297,20 @@ pure (Map.union m props) -getMaybeProp :: Context -> Thing -> Bits.BitGet (Maybe (StrictText.Text, Value.Value)) +getMaybeProp :: Context -> Thing -> BinaryBit.BitGet (Maybe (StrictText.Text, Value.Value)) getMaybeProp context thing = do hasProp <- getBool - if Boolean.unpack hasProp + if #unpack hasProp then do prop <- getProp context thing pure (Just prop) else pure Nothing -getProp :: Context -> Thing -> Bits.BitGet (StrictText.Text, Value.Value) +getProp :: Context -> Thing -> BinaryBit.BitGet (StrictText.Text, Value.Value) getProp context thing = do - let classId = thing & thingClassId - props <- case context & contextClassPropertyMap & IntMap.lookup classId of + let classId = #classId thing + props <- case context & #classPropertyMap & IntMap.lookup classId of Nothing -> fail ("could not find property map for class id " ++ show classId) Just x -> pure x let maxId = props & IntMap.keys & (0 :) & maximum @@ -263,7 +322,7 @@ pure (name, value) -getPropValue :: Context -> StrictText.Text -> Bits.BitGet Value.Value +getPropValue :: Context -> StrictText.Text -> BinaryBit.BitGet Value.Value getPropValue context name = case Map.lookup name Data.properties of Just property -> case StrictText.unpack property of "boolean" -> getBooleanProperty @@ -295,19 +354,19 @@ fail ("Don't know how to read property " ++ show name) -getBooleanProperty :: Bits.BitGet Value.Value +getBooleanProperty :: BinaryBit.BitGet Value.Value getBooleanProperty = do bool <- getBool pure (Value.VBoolean bool) -getByteProperty :: Bits.BitGet Value.Value +getByteProperty :: BinaryBit.BitGet Value.Value getByteProperty = do word <- getWord8 pure (Value.VByte word) -getCamSettingsProperty :: Bits.BitGet Value.Value +getCamSettingsProperty :: BinaryBit.BitGet Value.Value getCamSettingsProperty = do fov <- getFloat32 height <- getFloat32 @@ -318,7 +377,7 @@ pure (Value.VCamSettings fov height angle distance stiffness swivelSpeed) -getDemolishProperty :: Bits.BitGet Value.Value +getDemolishProperty :: BinaryBit.BitGet Value.Value getDemolishProperty = do atkFlag <- getBool atk <- getWord32 @@ -329,52 +388,52 @@ pure (Value.VDemolish atkFlag atk vicFlag vic vec1 vec2) -getEnumProperty :: Bits.BitGet Value.Value +getEnumProperty :: BinaryBit.BitGet Value.Value getEnumProperty = do - x <- Bits.getWord16be 10 + x <- BinaryBit.getWord16be 10 y <- if x == 1023 then getBool else fail ("unexpected enum value " ++ show x) pure (Value.VEnum (Word16.toWord16 x) y) -getExplosionProperty :: Bits.BitGet Value.Value +getExplosionProperty :: BinaryBit.BitGet Value.Value getExplosionProperty = do noGoal <- getBool - a <- if Boolean.unpack noGoal + a <- if #unpack noGoal then pure Nothing else fmap Just getInt32 b <- Vector.getIntVector pure (Value.VExplosion noGoal a b) -getFlaggedIntProperty :: Bits.BitGet Value.Value +getFlaggedIntProperty :: BinaryBit.BitGet Value.Value getFlaggedIntProperty = do flag <- getBool int <- getInt32 pure (Value.VFlaggedInt flag int) -getFloatProperty :: Bits.BitGet Value.Value +getFloatProperty :: BinaryBit.BitGet Value.Value getFloatProperty = do float <- getFloat32 pure (Value.VFloat float) -getGameModeProperty :: Context -> Bits.BitGet Value.Value +getGameModeProperty :: Context -> BinaryBit.BitGet Value.Value getGameModeProperty context = do let numBits = if atLeastNeoTokyo context then 8 else 2 - x <- Bits.getWord8 numBits + x <- BinaryBit.getWord8 numBits pure (Value.VGameMode (Word8.toWord8 x)) -getIntProperty :: Bits.BitGet Value.Value +getIntProperty :: BinaryBit.BitGet Value.Value getIntProperty = do int <- getInt32 pure (Value.VInt int) -getLoadoutOnlineProperty :: Bits.BitGet Value.Value +getLoadoutOnlineProperty :: BinaryBit.BitGet Value.Value getLoadoutOnlineProperty = do size <- fmap Word8.fromWord8 getWord8 values <- Monad.replicateM size (do @@ -386,7 +445,7 @@ pure (Value.VLoadoutOnline values) -getLoadoutProperty :: Bits.BitGet Value.Value +getLoadoutProperty :: BinaryBit.BitGet Value.Value getLoadoutProperty = do version <- getWord8 body <- getWord32 @@ -400,13 +459,13 @@ pure (Value.VLoadout version body decal wheels rocketTrail antenna topper g h) -getLocationProperty :: Bits.BitGet Value.Value +getLocationProperty :: BinaryBit.BitGet Value.Value getLocationProperty = do vector <- Vector.getIntVector pure (Value.VLocation vector) -getMusicStingerProperty :: Bits.BitGet Value.Value +getMusicStingerProperty :: BinaryBit.BitGet Value.Value getMusicStingerProperty = do flag <- getBool cue <- getWord32 @@ -414,17 +473,17 @@ pure (Value.VMusicStinger flag cue trigger) -getPickupProperty :: Bits.BitGet Value.Value +getPickupProperty :: BinaryBit.BitGet Value.Value getPickupProperty = do instigator <- getBool - instigatorId <- if Boolean.unpack instigator + instigatorId <- if #unpack instigator then fmap Just getWord32 else pure Nothing pickedUp <- getBool pure (Value.VPickup instigator instigatorId pickedUp) -getPrivateMatchSettingsProperty :: Bits.BitGet Value.Value +getPrivateMatchSettingsProperty :: BinaryBit.BitGet Value.Value getPrivateMatchSettingsProperty = do mutators <- getText joinableBy <- getWord32 @@ -435,19 +494,19 @@ pure (Value.VPrivateMatchSettings mutators joinableBy maxPlayers gameName password flag) -getQWordProperty :: Bits.BitGet Value.Value +getQWordProperty :: BinaryBit.BitGet Value.Value getQWordProperty = do qword <- getWord64 pure (Value.VQWord qword) -getRelativeRotationProperty :: Bits.BitGet Value.Value +getRelativeRotationProperty :: BinaryBit.BitGet Value.Value getRelativeRotationProperty = do vector <- Vector.getFloatVector pure (Value.VRelativeRotation vector) -getReservationProperty :: Context -> Bits.BitGet Value.Value +getReservationProperty :: Context -> BinaryBit.BitGet Value.Value getReservationProperty context = do -- I think this is the connection order. The first player to connect -- gets number 0, and it goes up from there. The maximum is 7, which @@ -462,34 +521,34 @@ -- The Neo Tokyo update added 6 bits to the reservation property that are -- always (as far as I can tell) 0. Monad.when (atLeastNeoTokyo context) (do - x <- Bits.getWord8 6 + x <- BinaryBit.getWord8 6 Monad.when (x /= 0b000000) (do fail (Printf.printf "Read 6 reservation bits and they weren't all 0! 0b%06b" x))) pure (Value.VReservation number systemId remoteId localId playerName a b) -getRigidBodyStateProperty :: Bits.BitGet Value.Value +getRigidBodyStateProperty :: BinaryBit.BitGet Value.Value getRigidBodyStateProperty = do flag <- getBool position <- Vector.getIntVector rotation <- Vector.getFloatVector - x <- if Boolean.unpack flag + x <- if #unpack flag then pure Nothing else fmap Just Vector.getIntVector - y <- if Boolean.unpack flag + y <- if #unpack flag then pure Nothing else fmap Just Vector.getIntVector pure (Value.VRigidBodyState flag position rotation x y) -getStringProperty :: Bits.BitGet Value.Value +getStringProperty :: BinaryBit.BitGet Value.Value getStringProperty = do string <- getText pure (Value.VString string) -getTeamPaintProperty :: Bits.BitGet Value.Value +getTeamPaintProperty :: BinaryBit.BitGet Value.Value getTeamPaintProperty = do team <- getWord8 primaryColor <- getWord8 @@ -499,7 +558,7 @@ pure (Value.VTeamPaint team primaryColor accentColor primaryFinish accentFinish) -getUniqueIdProperty :: Bits.BitGet Value.Value +getUniqueIdProperty :: BinaryBit.BitGet Value.Value getUniqueIdProperty = do (systemId, remoteId, localId) <- getUniqueId pure (Value.VUniqueId systemId remoteId localId) @@ -507,7 +566,7 @@ -- | Even though this is just a unique ID property, it must be handled -- specially because it sometimes doesn't have the remote or local IDs. -getPartyLeaderProperty :: Bits.BitGet Value.Value +getPartyLeaderProperty :: BinaryBit.BitGet Value.Value getPartyLeaderProperty = do systemId <- getWord8 (remoteId, localId) <- if systemId == 0 @@ -519,7 +578,7 @@ pure (Value.VUniqueId systemId remoteId localId) -getUniqueId :: Bits.BitGet (Word8.Word8, RemoteId.RemoteId, Maybe Word8.Word8) +getUniqueId :: BinaryBit.BitGet (Word8.Word8, RemoteId.RemoteId, Maybe Word8.Word8) getUniqueId = do systemId <- getWord8 remoteId <- getRemoteId systemId @@ -527,7 +586,7 @@ pure (systemId, remoteId, localId) -getRemoteId :: Word8.Word8 -> Bits.BitGet RemoteId.RemoteId +getRemoteId :: Word8.Word8 -> BinaryBit.BitGet RemoteId.RemoteId getRemoteId systemId = case systemId of 0 -> do splitscreenId <- BinaryBit.getBits 0 @@ -544,64 +603,6 @@ _ -> fail ("unknown system id " ++ show systemId) --- Data types - - -data Thing = Thing - { thingFlag :: Boolean.Boolean - , thingObjectId :: Int32.Int32 - , thingObjectName :: StrictText.Text - , thingClassId :: Int - , thingClassName :: StrictText.Text - , thingInitialization :: Initialization.Initialization - } deriving (Eq, Generics.Generic, Show) - -instance DeepSeq.NFData Thing - - --- { class stream id => { property stream id => name } } -type ClassPropertyMap = IntMap.IntMap (IntMap.IntMap StrictText.Text) - - --- { stream id => object name } -type ObjectMap = IntMap.IntMap StrictText.Text - - --- { class name => class id } -type ClassMap = Map.Map StrictText.Text Int - - -data Context = Context - { contextObjectMap :: ObjectMap - , contextClassPropertyMap :: ClassPropertyMap - , contextThings :: (IntMap.IntMap Thing) - , contextClassMap :: ClassMap - , contextKeyFrames :: (Set.Set Word) - , contextVersion :: Version.Version - } deriving (Eq, Generics.Generic, Show) - -instance DeepSeq.NFData Context - - -extractContext :: ReplayWithoutFrames.ReplayWithoutFrames -> Context -extractContext replay = Context - { contextObjectMap = CPM.getPropertyMap replay - , contextClassPropertyMap = CPM.getClassPropertyMap replay - , contextThings = IntMap.empty - , contextClassMap = CPM.getActorMap replay - , contextKeyFrames = replay - & ReplayWithoutFrames.keyFrames - & List.unpack - & map KeyFrame.frame - & map Word32.fromWord32 - & Set.fromList - , contextVersion = - [ replay & ReplayWithoutFrames.version1 - , replay & ReplayWithoutFrames.version2 - ] & map Word32.fromWord32 & Version.makeVersion - } - - -- Helpers @@ -610,7 +611,7 @@ -- function takes a context and returns true if the replay was saved by a game -- running at least the Neo Tokyo version. atLeastNeoTokyo :: Context -> Bool -atLeastNeoTokyo context = contextVersion context >= neoTokyoVersion +atLeastNeoTokyo context = #version context >= neoTokyoVersion -- Constants @@ -631,29 +632,29 @@ -- Type-restricted helpers. -getBool :: Bits.BitGet Boolean.Boolean +getBool :: BinaryBit.BitGet Boolean.Boolean getBool = BinaryBit.getBits 0 -getFloat32 :: Bits.BitGet Float32.Float32 +getFloat32 :: BinaryBit.BitGet Float32.Float32 getFloat32 = BinaryBit.getBits 0 -getInt32 :: Bits.BitGet Int32.Int32 +getInt32 :: BinaryBit.BitGet Int32.Int32 getInt32 = BinaryBit.getBits 0 -getText :: Bits.BitGet Text.Text +getText :: BinaryBit.BitGet Text.Text getText = BinaryBit.getBits 0 -getWord8 :: Bits.BitGet Word8.Word8 +getWord8 :: BinaryBit.BitGet Word8.Word8 getWord8 = BinaryBit.getBits 0 -getWord32 :: Bits.BitGet Word32.Word32 +getWord32 :: BinaryBit.BitGet Word32.Word32 getWord32 = BinaryBit.getBits 0 -getWord64 :: Bits.BitGet Word64.Word64 +getWord64 :: BinaryBit.BitGet Word64.Word64 getWord64 = BinaryBit.getBits 0 diff --git a/octane.cabal b/octane.cabal --- a/octane.cabal +++ b/octane.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: octane -version: 0.13.4 +version: 0.14.0 synopsis: Parse Rocket League replays. description: Octane parses Rocket League replays. category: Game @@ -44,10 +44,12 @@ , bytestring ==0.10.* , containers ==0.5.* , data-binary-ieee754 ==0.4.* + , data-default-class <0.2 , deepseq ==1.4.* , file-embed ==0.0.* , http-client >=0.4.30 && <0.6 , http-client-tls >=0.2 && <0.4 + , overloaded-records ==0.4.* , regex-compat ==0.95.* , text ==1.2.* , unordered-containers ==0.2.* diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -41,10 +41,12 @@ - bytestring ==0.10.* - containers ==0.5.* - data-binary-ieee754 ==0.4.* + - data-default-class <0.2 - deepseq ==1.4.* - file-embed ==0.0.* - http-client >=0.4.30 && <0.6 - http-client-tls >=0.2 && <0.4 + - overloaded-records ==0.4.* - regex-compat ==0.95.* - text ==1.2.* - unordered-containers ==0.2.* @@ -79,4 +81,4 @@ - -with-rtsopts=-N main: Main.hs source-dirs: test-suite -version: '0.13.4' +version: '0.14.0' diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,1 +1,1 @@ -resolver: nightly-2016-07-05 +resolver: nightly-2016-08-18 diff --git a/test-suite/Main.hs b/test-suite/Main.hs --- a/test-suite/Main.hs +++ b/test-suite/Main.hs @@ -4,6 +4,7 @@ import qualified Test.Tasty as Tasty import qualified Test.Tasty.Hspec as Hspec + main :: IO () main = do test <- Hspec.testSpec "octane" spec