rattletrap-0.2.0: executable/Main.hs

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Main
  ( main
  ) where

import Rattletrap

import qualified Control.Monad as Monad
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Casing as Casing
import qualified Data.Aeson.TH as Aeson
import qualified Data.Binary.Get as Binary
import qualified Data.Binary.Put as Binary
import qualified Data.ByteString.Lazy as ByteString
import qualified Data.Version as Version
import qualified Language.Haskell.TH as TH
import qualified System.Environment as Environment

main :: IO ()
main = do
  args <- Environment.getArgs
  mainWithArgs args

mainWithArgs :: [String] -> IO ()
mainWithArgs args =
  case args of
    ["version"] -> putStrLn (Version.showVersion version)
    "decode":files -> do
      (getInput, putOutput) <- getIO files
      input <- getInput
      let replay = Binary.runGet getReplay input
      let output = Aeson.encode replay
      putOutput output
    "encode":files -> do
      (getInput, putOutput) <- getIO files
      input <- getInput
      case Aeson.eitherDecode input of
        Left message -> fail ("could not parse JSON: " ++ message)
        Right replay -> do
          let output = Binary.runPut (putReplay replay)
          putOutput output
    _ -> fail ("unexpected arguments " ++ show args)

getIO
  :: Monad m
  => [FilePath] -> m (IO ByteString.ByteString, ByteString.ByteString -> IO ())
getIO files =
  case files of
    [] -> pure (ByteString.getContents, ByteString.putStr)
    [i] -> pure (ByteString.readFile i, ByteString.putStr)
    [i, o] -> pure (ByteString.readFile i, ByteString.writeFile o)
    _ -> fail ("unexpected arguments " ++ show files)

$(let optionsFor name =
        (Casing.aesonDrop (length (TH.nameBase name)) Casing.snakeCase)
        { Aeson.constructorTagModifier = Casing.snakeCase
        , Aeson.omitNothingFields = True
        , Aeson.sumEncoding = Aeson.ObjectWithSingleField
        , Aeson.unwrapUnaryRecords = True
        }
      deriveJSON declarations name = do
        newDeclarations <- Aeson.deriveJSON (optionsFor name) name
        pure (newDeclarations ++ declarations)
      names =
        [ ''Attribute
        , ''AttributeMapping
        , ''AttributeValue
        , ''BooleanAttributeValue
        , ''ByteAttributeValue
        , ''Cache
        , ''CamSettingsAttributeValue
        , ''ClassMapping
        , ''ClubColorsAttributeValue
        , ''CompressedWord
        , ''CompressedWordVector
        , ''Content
        , ''DemolishAttributeValue
        , ''DestroyedReplicationValue
        , ''Dictionary
        , ''EnumAttributeValue
        , ''ExplosionAttributeValue
        , ''FlaggedIntAttributeValue
        , ''Float32
        , ''FloatAttributeValue
        , ''Frame
        , ''GameModeAttributeValue
        , ''Header
        , ''Initialization
        , ''Int32
        , ''Int8
        , ''Int8Vector
        , ''IntAttributeValue
        , ''KeyFrame
        , ''List
        , ''LoadoutAttributeValue
        , ''LoadoutOnlineAttributeValue
        , ''LoadoutsAttributeValue
        , ''LoadoutsOnlineAttributeValue
        , ''LocationAttributeValue
        , ''Mark
        , ''Message
        , ''MusicStingerAttributeValue
        , ''PartyLeaderAttributeValue
        , ''PickupAttributeValue
        , ''PrivateMatchSettingsAttributeValue
        , ''Property
        , ''PropertyValue
        , ''QWordAttributeValue
        , ''RemoteId
        , ''Replay
        , ''Replication
        , ''ReplicationValue
        , ''ReservationAttributeValue
        , ''RigidBodyStateAttributeValue
        , ''SpawnedReplicationValue
        , ''StringAttributeValue
        , ''TeamPaintAttributeValue
        , ''Text
        , ''UniqueIdAttributeValue
        , ''UpdatedReplicationValue
        , ''Vector
        , ''WeldedInfoAttributeValue
        , ''Word32
        , ''Word64
        , ''Word8
        ]
  in Monad.foldM deriveJSON [] names)