haxparse (empty) → 0.1.0.0
raw patch · 10 files changed
+768/−0 lines, 10 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, data-binary-ieee754, data-default, lens, mtl, optparse-applicative, parsec, split, template-haskell, transformers, utf8-string, zlib
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- haxparse.cabal +67/−0
- src/HaxParse/AST.hs +98/−0
- src/HaxParse/AST/TH.hs +18/−0
- src/HaxParse/Options.hs +103/−0
- src/HaxParse/Output.hs +11/−0
- src/HaxParse/Output/Plain.hs +124/−0
- src/HaxParse/Parser.hs +309/−0
- src/Main.hs +15/−0
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2013 Joel Taylor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haxparse.cabal view
@@ -0,0 +1,67 @@+-- Initial haxparse.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: haxparse+version: 0.1.0.0+synopsis: Readable HaxBall replays+description: Provides an interface for parsing HaxBall replays.+homepage: https://github.com/joelteon/haxparse+license: MIT+license-file: LICENSE+author: Joel Taylor+maintainer: me@joelt.io+category: Data+build-type: Simple+cabal-version: >=1.8++source-repository head+ type: git+ location: https://github.com/joelteon/haxparse.git++library+ exposed-modules: HaxParse.AST+ HaxParse.AST.TH+ HaxParse.Parser+ build-depends: base == 4.6.*,+ binary == 0.7.*,+ bytestring == 0.10.*,+ containers == 0.5.*,+ data-binary-ieee754 == 0.4.*,+ data-default == 0.5.*,+ lens == 3.9.*,+ optparse-applicative == 0.5.*,+ mtl == 2.1.*,+ parsec == 3.1.*,+ split == 0.2.*,+ template-haskell == 2.8.*,+ transformers == 0.3.*,+ utf8-string == 0.3.*,+ zlib == 0.5.*+ hs-source-dirs: src+ extensions: FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TemplateHaskell++executable haxparse+ main-is: Main.hs+ other-modules: HaxParse.AST.TH+ HaxParse.AST+ HaxParse.Options+ HaxParse.Output.Plain+ HaxParse.Output+ HaxParse.Parser+ hs-source-dirs: src+ build-depends: base == 4.6.*,+ binary == 0.7.*,+ bytestring == 0.10.*,+ containers == 0.5.*,+ data-binary-ieee754 == 0.4.*,+ data-default == 0.5.*,+ lens == 3.9.*,+ optparse-applicative == 0.5.*,+ mtl == 2.1.*,+ parsec == 3.1.*,+ split == 0.2.*,+ template-haskell == 2.8.*,+ transformers == 0.3.*,+ utf8-string == 0.3.*,+ zlib == 0.5.*+ extensions: FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TemplateHaskell
+ src/HaxParse/AST.hs view
@@ -0,0 +1,98 @@+module HaxParse.AST where++import Data.ByteString.Lazy+import Data.IntMap+import Data.Word+import HaxParse.AST.TH++data Move = Nop | Move [Direction] | Kick | MoveKick [Direction] deriving Show++data Direction = Up | Left | Down | Right deriving Show++data Action = Action { actPlayerId :: Key+ , actFrameCount :: Word32+ , actEvent :: Event+ } deriving Show++data Side = Red | Blue | Spec deriving Show++data Event = NewPlayer { npId :: Key+ , npName :: ByteString+ , npAdmin :: Bool+ , npCountry :: ByteString+ }+ | Departure { dId :: Word32+ , kicked :: Bool+ , banned :: Bool+ , reason :: Maybe ByteString+ }+ | ChangeAvatar ByteString+ | Chat ByteString+ | StartMatch+ | StopMatch+ | TeamChange Word32 Side+ | DiscMove Move+ | PingBroadcast [(Word32, Word8)]+ | TimeUpdate deriving (Show)++makeIsFns ''Event++data Stadium = Classic | Easy | Small | Big+ | Rounded | Hockey | BigHockey | BigEasy+ | BigRounded | Huge | Custom+ deriving (Bounded, Eq, Enum, Ord, Show)++data Color = Color String deriving Show++data Mask = Mask [String] deriving Show++data Disc = Disc { discId :: Word32+ , pos :: (Double, Double)+ , speed :: (Double, Double)+ , radius :: Double+ , bCoefficient :: Double+ , invMass :: Double+ , damping :: Double+ , color :: Color+ , mask :: Mask+ , group :: Mask+ } deriving (Show)++data Room = Room { roomName :: ByteString+ , locked :: Bool+ , scoreLimit :: Word8+ , timeLimit :: Word8+ , rules :: Word32+ , kickoffTaken :: Bool+ , kickoffSide :: Side+ , ballCoords :: (Double, Double)+ , redScore :: Word32+ , blueScore :: Word32+ , timer :: Double+ , pauseTimer :: Word8+ , stadium :: Stadium+ } deriving (Show)++data Player = Player { name :: ByteString+ , initial :: Bool+ , admin :: Bool+ , team :: Side+ , number :: Word8+ , avatar :: ByteString+ , input :: Word32+ , autoKick :: Bool+ , desync :: Bool+ , country :: ByteString+ , handicap :: Word16+ , pDiscId :: Word32+ } deriving (Show)++data Replay = Replay { version :: Word32+ , frameCount :: Word32+ , firstFrame :: Word32+ , room :: Room+ , inProgress :: Bool+ , discs :: [Disc]+ , players :: IntMap Player+ , events :: [Action]+ } deriving Show
+ src/HaxParse/AST/TH.hs view
@@ -0,0 +1,18 @@+module HaxParse.AST.TH where++import Language.Haskell.TH.Syntax++makeIsFns :: Name -> Q [Dec]+makeIsFns name = do inf <- reify name+ case inf of TyConI (DataD _ _ _ recs _) -> fmap concat $ mapM makeIsFn recs+ x -> error $ "Expected a datatype, got " ++ show x++makeIsFn :: Con -> Q [Dec]+makeIsFn (RecC con _) = do s <- sig+ return [ SigD (mkName $ "is" ++ nameBase con) s+ , FunD (mkName $ "is" ++ nameBase con) [matchClause, noMatchClause] ]+ where sig = [t|$(return . ConT $ mkName "Event") -> Bool|]+ matchClause = Clause [RecP con []] (NormalB (ConE $ mkName "True")) []+ noMatchClause = Clause [WildP] (NormalB (ConE $ mkName "False")) []+makeIsFn (NormalC con _) = makeIsFn (RecC con [])+makeIsFn x = error $ "Unhandled variant " ++ show x
+ src/HaxParse/Options.hs view
@@ -0,0 +1,103 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HaxParse.Options (+ OutputType(..),+ Opts(..),+ TimeFormat(..),+ fullOpts+) where++import Data.Char+import Data.List.Split+import HaxParse.AST hiding (Left, Right)+import Options.Applicative++data OutputType = Plain | JSON deriving Show++data TimeFormat = Frame | Second | Both deriving Show++type EventFilter = Action -> Bool++instance Show EventFilter where show _ = "(filter)"++data Opts = Opts { outputType :: OutputType+ , showRoom :: Bool+ , showDiscs :: Bool+ , showPlayers :: Bool+ , showEvents :: Bool+ , timeFormat :: TimeFormat+ , file :: FilePath+ , eventTypes :: [EventFilter]+ } deriving Show++outputTypeReader :: String -> Either ParseError OutputType+outputTypeReader s+ | map toLower s == "json" = Right JSON+ | map toLower s == "plain" = Right Plain+ | otherwise = Left . ErrorMsg $ "unknown output type " ++ s++eventTypeReader :: String -> Either ParseError [EventFilter]+eventTypeReader evs = sequence . map (fmap (. actEvent) . eventTypeReaderSingle . trim) $ splitOn "," evs+ where trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse++eventTypeReaderSingle :: String -> Either ParseError (Event -> Bool)+eventTypeReaderSingle s+ | map toLower s `elem` ["new-player", "np"] = Right isNewPlayer+ | map toLower s `elem` ["departure", "d"] = Right isDeparture+ | map toLower s `elem` ["change-avatar", "ca"] = Right isChangeAvatar+ | map toLower s `elem` ["chat", "c"] = Right isChat+ | map toLower s `elem` ["start-match", "start"] = Right isStartMatch+ | map toLower s `elem` ["stop-match", "stop"] = Right isStopMatch+ | map toLower s `elem` ["team-change", "tc"] = Right isTeamChange+ | map toLower s `elem` ["disc-move", "m"] = Right isDiscMove+ | map toLower s `elem` ["ping-broadcast", "p"] = Right isPingBroadcast+ | map toLower s `elem` ["time-update", "t"] = Right isTimeUpdate+ | otherwise = Left . ErrorMsg $ "unknown event type " ++ s++timeFormatReader :: String -> Either ParseError TimeFormat+timeFormatReader x+ | map toLower x == "frame" = Right Frame+ | map toLower x == "second" = Right Second+ | map toLower x == "both" = Right Both+ | otherwise = Left . ErrorMsg $ "unknown time format " ++ x++opts :: Parser Opts+opts = Opts <$> nullOption ( long "output-type"+ <> short 'o'+ <> metavar "TYPE"+ <> help "Set output type: one of plain [default], json"+ <> reader outputTypeReader+ <> value Plain )+ <*> switch ( long "show-room"+ <> short 'r'+ <> help "Dump room information"+ <> value False )+ <*> switch ( long "show-discs"+ <> short 'd'+ <> help "Dump disc information"+ <> value False )+ <*> switch ( long "show-players"+ <> short 'p'+ <> help "Dump player information"+ <> value False )+ <*> switch ( long "show-events"+ <> short 'e'+ <> help "Dump event information"+ <> value False )+ <*> nullOption ( long "time-format"+ <> short 't'+ <> metavar "FORMAT"+ <> help "Change timestamp format: frame, second, or both"+ <> reader timeFormatReader+ <> value Frame )+ <*> argument str (metavar "FILE")+ <*> nullOption ( long "event-types"+ <> short 'f'+ <> metavar "TYPE"+ <> help "Filter events by type: new-player (np), departure (d), change-avatar (ca), chat (c), start-match (start), stop-match (stop), team-change (tc), disc-move (m), ping-broadcast (p), time-update (t). This option implies --show-events."+ <> reader eventTypeReader+ <> value [] )++fullOpts :: ParserInfo Opts+fullOpts = info (helper <*> opts)+ (fullDesc <> progDesc "Parse .hbr files.")
+ src/HaxParse/Output.hs view
@@ -0,0 +1,11 @@+module HaxParse.Output (+ outputWith+) where++import HaxParse.AST+import qualified HaxParse.Output.Plain as Plain+import HaxParse.Options++outputWith :: Opts -> Replay -> IO ()+outputWith opts x = case outputType opts of JSON -> error "no JSON renderer yet"+ _ -> Plain.render opts x
+ src/HaxParse/Output/Plain.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE MultiWayIf #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module HaxParse.Output.Plain (+ render+) where++import Control.Monad.Reader+import Data.ByteString.Lazy.UTF8 (toString)+import qualified Data.IntMap as I+import HaxParse.AST+import HaxParse.Options hiding (showRoom)+import qualified HaxParse.Options as O+import Prelude hiding (Left, Right)+import System.IO+import Text.Printf++type RenderState = ReaderT (Opts, I.IntMap Player) IO++render :: Opts -> Replay -> IO ()+render o re = do+ hSetEncoding stdout utf8+ printf "HBRP version %d.\n" (version re)+ let fullSec = fromIntegral (frameCount re) / 60 :: Double+ minutes = floor (fullSec / 60) :: Integer+ seconds = fullSec - fromIntegral (minutes * 60)+ printf "Length: %d frames (%d:%.3f).\n" (frameCount re) minutes seconds+ printf "First frame: %d.\n" (firstFrame re)+ when (O.showRoom o) $ showRoom $ room re+ printf "The game is %sin progress.\n" $ if inProgress re then "" :: String+ else "not "+ when (showDiscs o) $ if null $ discs re+ then putStrLn "Discs: none."+ else putStrLn "Discs:" >> mapM_ showDisc (discs re)+ when (showPlayers o) $ do putStrLn "Players:"+ mapM_ showPlayer . I.toList $ players re+ when (showEvents o) $ do putStrLn "Events:"+ let filteredEvents = if null (eventTypes o)+ then events re+ else filter (\ev -> any ($ ev) (eventTypes o)) (events re)+ forM_ filteredEvents $ \f -> runReaderT (showAction f) (o, players re)++showRoom :: Room -> IO ()+showRoom r = do+ printf "Room name: %s.\n" (toString $ roomName r)+ printf "The room is %slocked.\n" $ if locked r then "" :: String else "not "+ printf "Score limit: %d.\nTime limit: %d min.\n" (scoreLimit r) (timeLimit r)+ printf "Rules? %d.\n" (rules r)+ printf "The kickoff has %sbeen taken%s.\n"+ (if kickoffTaken r then "" :: String else "not ")+ (if kickoffTaken r then " by " ++ show (kickoffSide r) else "")+ uncurry (printf "The ball is at (%.3f,%.3f).\n") (ballCoords r)+ printf "Score: Red %d - %d Blue.\n" (redScore r) (blueScore r)+ printf "Current timer: %.3f%s.\n"+ (timer r)+ (if pauseTimer r > 0 then printf " (unpaused in %d sec)" (pauseTimer r)+ else "" :: String)+ showStadium $ stadium r++showStadium :: Stadium -> IO ()+showStadium s = printf "Current stadium: %s.\n" (show s)++showDisc :: Disc -> IO ()+showDisc = undefined++showPlayer :: (I.Key, Player) -> IO ()+showPlayer (k, p) = do+ printf "#%d %s%s\n" k (toString $ name p) (if admin p then " (admin)" :: String else "")+ unless (initial p) $ printf " This player joined the room during the replay.\n"+ printf " Team: %s\n" (show $ team p)+ printf " Number: %d\n" (number p)+ printf " Avatar: %s\n" (toString $ avatar p)+ printf " Input: %d\n" (input p)+ printf " Banned: %s\n" (show $ autoKick p)+ printf " Desynced: %s\n" (show $ desync p)+ printf " Country: %s\n" (toString $ country p)+ printf " Handicap: %d\n" (handicap p)+ printf " Disc ID: %s\n" (if pDiscId p + 1 == 0 then "(none)" else show (pDiscId p))++showAction :: Action -> RenderState ()+showAction (Action p fc ev) = do+ (o,ps) <- ask+ e <- showEv ev (ps I.! p)+ let prelude = case timeFormat o of+ Frame -> printf "frame %05d" fc+ Second -> printf "(%02d:%06.3f)" minutes seconds+ Both -> printf "frame %05d (%02d:%06.3f)" fc minutes seconds+ sec :: Double+ sec = fromIntegral fc / 60+ minutes :: Integer+ minutes = floor (sec / 60)+ seconds :: Double+ seconds = sec - (fromIntegral minutes * 60)+ liftIO $ printf "%s: %s\n" (prelude :: String) e++showEv :: Event -> Player -> RenderState String+showEv (PingBroadcast ps) _ = return $ printf "ping update: %s" $ show ps+showEv (Chat bs) p = return $ printf "%s: \"%s\"" (toString $ name p) (toString bs)+showEv StartMatch p = return $ printf "%s starts match" (toString $ name p)+showEv (DiscMove ds) p = return $ printf "%s %s" (toString $ name p) (showMoves ds)+showEv (NewPlayer _ n _ c) _ = return $ printf "new player joins: %s (from %s)" (toString n) (toString c)+showEv (ChangeAvatar s) p = return $ printf "%s changes avatar to \"%s\"" (toString $ name p) (toString s)+showEv (Departure d k b r) p = do ps <- asks snd+ let n = toString . name $ ps I.! fromIntegral d+ if | b -> return $ printf "%s bans %s (%s)" n (toString $ name p) (maybe "no reason" toString r)+ | k -> return $ printf "%s kicks %s (%s)" n (toString $ name p) (maybe "no reason" toString r)+ | otherwise -> return $ printf "%s leaves" n+showEv StopMatch p = return $ printf "%s stops match" (toString $ name p)+showEv (TeamChange m t) p = do ps <- asks snd+ let n = toString . name $ ps I.! fromIntegral m+ return $ printf "%s moves %s to %s" (toString $ name p) n (show t)+showEv x _ = error $ show x++showMoves :: Move -> String+showMoves Kick = "kicks"+showMoves Nop = "stops moving"+showMoves (Move ms) = printf "moves %s" $ join (map showDir ms)+showMoves (MoveKick ms) = printf "moves %s and kicks" $ join (map showDir ms)++showDir :: Direction -> String+showDir Left = "←"+showDir Up = "↑"+showDir Right = "→"+showDir Down = "↓"
+ src/HaxParse/Parser.hs view
@@ -0,0 +1,309 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module HaxParse.Parser where++import Codec.Compression.Zlib+import Control.Applicative ((<$>), (<*>), pure)+import Control.Lens hiding (Action)+import Control.Monad+import Data.Binary+import Data.Binary.Get+import Data.Binary.IEEE754+import Data.Bits+import qualified Data.ByteString.Lazy.Char8 as C+import Data.Char+import Data.Default+import qualified Data.IntMap as I+import Data.Monoid+import HaxParse.AST+import Numeric+import Prelude hiding (Left, Right)+import Text.Parsec.Char+import Text.Parsec.Combinator+import Text.Parsec.Error+import Text.Parsec.Prim++data ParserState = ParserState { _frame :: Word32+ , _curDiscId :: Word32+ , _playerList :: I.IntMap Player+ }++instance Default ParserState where def = ParserState 0 0 mempty++makeLenses ''ParserState++type Parser = Parsec C.ByteString ParserState++instance (Monad m) => Stream C.ByteString m Char where+ uncons = return . C.uncons++parseFromFile :: Parser a -> FilePath -> IO (Either ParseError a)+parseFromFile p fname = do inp <- C.readFile fname+ return (runP p def fname inp)++parseFile :: FilePath -> IO (Either ParseError Replay)+parseFile m = parseFromFile haxParser m++haxParser :: Parser Replay+haxParser = do vers <- int32+ header <- count 4 anyChar+ when (header /= "HBRP") . fail $ "Did not find correct HBR header. Expected HBRP, found " ++ show header+ framecount <- int32+ setInput . decompress =<< getInput+ firstframe <- int32+ r <- room_+ prog <- bool+ d <- if prog then discs_ else pure []+ players_+ count 14 $ char '\NUL'+ ev <- many event+ plist <- fmap (^. playerList) getState+ return Replay { version = vers+ , frameCount = framecount+ , firstFrame = firstframe+ , room = r+ , inProgress = prog+ , discs = d+ , players = plist+ , events = ev+ }++room_ :: Parser Room+room_ = do roomname <- str+ l <- bool+ scorelimit <- int8+ timelimit <- int8+ r <- int32+ kotaken <- bool+ koside <- side+ ballx <- double+ bally <- double+ redscore <- int32+ bluescore <- int32+ time <- double+ pausetimer <- int8+ st <- stadium_+ return Room { roomName = roomname+ , locked = l+ , scoreLimit = scorelimit+ , timeLimit = timelimit+ , rules = r+ , kickoffTaken = kotaken+ , kickoffSide = koside+ , ballCoords = (ballx, bally)+ , redScore = redscore+ , blueScore = bluescore+ , timer = time+ , pauseTimer = pausetimer+ , stadium = st+ }+++int64 :: Parser Word64+int64 = do s <- count 8 anyChar+ return $ runGet getWord64be $ C.pack s++double :: Parser Double+double = do s <- count 8 anyChar+ return $ runGet getFloat64be $ C.pack s++int32 :: Parser Word32+int32 = do s <- count 4 anyChar+ return $ runGet getWord32be $ C.pack s++int16 :: Parser Word16+int16 = do s <- count 2 anyChar+ return $ runGet getWord16be $ C.pack s++int8 :: Parser Word8+int8 = fromIntegral . ord <$> anyChar++str :: Parser C.ByteString+str = do len <- int16+ C.pack <$> count (fromIntegral len) anyChar++bool :: Parser Bool+bool = do m <- ord <$> anyChar+ case m of 0 -> return False+ 1 -> return True+ x -> fail $ "Unexpected value for boolean: " ++ show x++side :: Parser Side+side = do s <- int8+ case s of 1 -> return Red+ 2 -> return Blue+ _ -> return Spec++stadium_ :: Parser Stadium+stadium_ = do st <- int8+ if st < 255 then return $ [minBound..maxBound] !! fromIntegral st+ else fail $ "Custom stadiums not handled yet!"++discs_ :: Parser [Disc]+discs_ = do s <- int32+ count (fromIntegral s) disc++disc :: Parser Disc+disc = do discid <- view curDiscId <$> getState+ modifyState (curDiscId +~ 1)+ posx <- double+ posy <- double+ speedx <- double+ speedy <- double+ r <- double+ bco <- double+ im <- double+ damp <- double+ col <- Color . flip showHex "" <$> int32+ m <- mask_+ g <- mask_+ return Disc { discId = discid+ , pos = (posx, posy)+ , speed = (speedx, speedy)+ , radius = r+ , bCoefficient = bco+ , invMass = im+ , damping = damp+ , color = col+ , mask = m+ , group = g+ }++mask_ :: Parser Mask+mask_ = do start <- int32+ if start + 1 == 0 then pure $ Mask ["all"]+ else return . Mask $ go start []+ where go 0 ms = ms+ go m xs | m .&. 32 /= 0 = go (m .&. (complement 32)) ("wall":xs)+ | m .&. 16 /= 0 = go (m .&. (complement 16)) ("blueKO":xs)+ | m .&. 8 /= 0 = go (m .&. (complement 8)) ("redKO":xs)+ | m .&. 4 /= 0 = go (m .&. (complement 4)) ("blue":xs)+ | m .&. 2 /= 0 = go (m .&. (complement 2)) ("red":xs)+ | m .&. 1 /= 0 = go (m .&. (complement 1)) ("ball":xs)+ | otherwise = fail $ "Heh??? " ++ show m++players_ :: Parser ()+players_ = do p <- int32+ void $ count (fromIntegral p) player++player :: Parser ()+player = do pid <- fromIntegral <$> int32+ uname <- str+ a <- bool+ t <- side+ n <- int8+ av <- str+ inp <- int32+ ak <- bool+ d <- bool+ ct <- str+ h <- int16+ did <- int32+ let p = Player { name = uname+ , initial = True+ , admin = a+ , team = t+ , number = n+ , avatar = av+ , input = inp+ , autoKick = ak+ , desync = d+ , country = ct+ , handicap = h+ , pDiscId = did+ }+ modifyState (playerList %~ I.insert pid p)++event :: Parser Action+event = do timeUpdate <- bool <?> "is it a time update?"+ when timeUpdate $ do frames <- int32+ modifyState (frame +~ frames)+ fc <- view frame <$> getState+ pid <- fromIntegral <$> int32+ evty <- int8+ result <- case evty of 0 -> newPlayer+ 1 -> departure+ 2 -> Chat <$> str+ 4 -> pure StartMatch+ 5 -> pure StopMatch+ 6 -> discMove+ 7 -> TeamChange <$> int32 <*> side+ 10 -> ChangeAvatar <$> str+ 15 -> pingBroadcast+ x -> fail $ "heh non-exhaustive match for " ++ show x+ return $ Action pid fc result++departure :: Parser Event+departure = do p <- int16+ k <- bool+ r <- if k then Just <$> str else pure Nothing+ b <- bool+ return Departure { dId = fromIntegral p+ , kicked = k+ , banned = b+ , reason = r }++newPlayer :: Parser Event+newPlayer = do i <- fromIntegral <$> int32+ n <- str+ ai <- bool+ ct <- str+ let p = Player { name = n+ , initial = False+ , admin = ai+ , team = Spec+ , number = 0+ , avatar = ""+ , input = 0+ , autoKick = False+ , desync = False+ , country = ct+ , handicap = 0+ , pDiscId = -1+ }+ modifyState (playerList %~ I.insert i p)+ return $ NewPlayer { npId = i+ , npName = n+ , npAdmin = ai+ , npCountry = ct+ }++pingBroadcast :: Parser Event+pingBroadcast = do p <- int8+ PingBroadcast . zip [0..] . map (*4) <$> count (fromIntegral p) int8++discMove :: Parser Event+discMove = do m <- int8+ return . DiscMove $ [ Nop+ , Move [Up]+ , Move [Down]+ , Move [Up, Down]+ , Move [Left]+ , Move [Up, Left]+ , Move [Down, Left]+ , Move [Up, Down, Left]+ , Move [Right]+ , Move [Up, Right]+ , Move [Down, Right]+ , Move [Up, Down, Right]+ , Move [Left, Right]+ , Move [Up, Left, Right]+ , Move [Down, Left, Right]+ , Move [Up, Down, Left, Right]+ , Kick+ , MoveKick [Up]+ , MoveKick [Down]+ , MoveKick [Up, Down]+ , MoveKick [Left]+ , MoveKick [Up, Left]+ , MoveKick [Down, Left]+ , MoveKick [Up, Down, Left]+ , MoveKick [Right]+ , MoveKick [Up, Right]+ , MoveKick [Down, Right]+ , MoveKick [Up, Down, Right]+ , MoveKick [Left, Right]+ , MoveKick [Up, Left, Right]+ , MoveKick [Down, Left, Right]+ , MoveKick [Up, Down, Left, Right]] !! fromIntegral m
+ src/Main.hs view
@@ -0,0 +1,15 @@+import qualified Data.ByteString.Lazy as LB+import HaxParse.Parser+import HaxParse.Options+import HaxParse.Output+import Options.Applicative+import System.Exit+import System.IO++main :: IO ()+main = do opts <- execParser fullOpts+ res <- parseFile $ file opts+ let newOpts = if null (eventTypes opts) then opts else opts { showEvents = True }+ case res of Left m -> do hPutStrLn stderr $ "Parsing failed: " ++ show m+ exitFailure+ Right s -> outputWith newOpts s