module BuildTools.Template2Hs where import Control.Monad import Data.Char import Data.List import Data.Function import Data.Word import System.Environment import Text.Parsec import qualified Text.Parsec.Token as P import Text.Parsec.Language (emptyDef) lexer = P.makeTokenParser (emptyDef { P.commentLine = "//" }) braces = P.braces lexer identifier = P.identifier lexer natural = P.natural lexer float = P.float lexer whiteSpace = P.whiteSpace lexer symbol = P.symbol lexer data Frequency = Low Integer | Medium Integer | High Integer | Fixed Integer deriving Show frequency = do typ <- identifier case typ of "Low" -> do n <- natural return (Low n) "Medium" -> do n <- natural return (Medium n) "High" -> do n <- natural return (High n) "Fixed" -> do n <- natural return (Fixed n) _ -> fail "Unrecognized frequency" data Quantity = Single | Multiple Integer | Variable deriving (Eq, Show) quantity = do typ <- identifier case typ of "Single" -> return Single "Multiple" -> do n <- natural return (Multiple n) "Variable" -> return Variable _ -> fail "Unrecognized quantity" data Type = TypeNull | TypeFixed Integer | TypeVariable Integer | TypeU8 | TypeU16 | TypeU32 | TypeU64 | TypeS8 | TypeS16 | TypeS32 | TypeS64 | TypeF32 | TypeF64 | TypeVector3 | TypeVector3d | TypeVector4 | TypeQuaternion | TypeUUID | TypeBool | TypeIPAddr | TypeIPPort deriving (Eq, Show) typeName = do typ <- identifier case typ of "Null" -> return TypeNull "Fixed" -> do n <- natural return (TypeFixed n) "Variable" -> do n <- natural return (TypeVariable n) "U8" -> return TypeU8 "U16" -> return TypeU16 "U32" -> return TypeU32 "U64" -> return TypeU64 "S8" -> return TypeS8 "S16" -> return TypeS16 "S32" -> return TypeS32 "S64" -> return TypeS64 "F32" -> return TypeF32 "F64" -> return TypeF64 "LLVector3" -> return TypeVector3 "LLVector3d" -> return TypeVector3d "LLVector4" -> return TypeVector4 "LLQuaternion" -> return TypeQuaternion "LLUUID" -> return TypeUUID "BOOL" -> return TypeBool "IPADDR" -> return TypeIPAddr "IPPORT" -> return TypeIPPort _ -> fail "Unrecognized type" data Field = Field { fieldName :: String, fieldRecord :: String, fieldType :: Type } deriving (Eq, Show) field pfx = braces $ do name <- identifier typ <- typeName return (Field name (lowerCase (pfx ++ "_" ++ name)) typ) where lowerCase (x:xs) = toLower x : xs data Block = Block { blockName :: String, blockDataName :: String, blockQuantity :: Quantity, blockFields :: [Field] } deriving (Eq, Show) block msg = braces $ do name <- identifier let dname = msg ++ "_" ++ name qty <- quantity flds <- many (field dname) return (Block name dname qty flds) data Message = Message { messageName :: String, messageFrequency :: Frequency, messageTrusted :: Bool, messageZerocoded :: Bool, messageBlocks :: [Block] } deriving Show trust = do val <- identifier case val of "Trusted" -> return True "NotTrusted" -> return False _ -> fail "Unrecognized trust level" encoding = do val <- identifier case val of "Unencoded" -> return False "Zerocoded" -> return True _ -> fail "Unrecognized encoding" message = braces $ do name <- identifier freq <- frequency trst <- trust enc <- encoding optionMaybe identifier -- UDPDeprecated, or UDPBlackListed blks <- many (block name) return (Message name freq trst enc blks) data Template = Template { templateVersion :: Double, templateMessages :: [Message] } deriving Show template = do whiteSpace verkw <- symbol "version" ver <- float msgs <- many message return (Template ver msgs) ----------------------------------------------------------------------------- genSource templ = frontMatter ++ "\n\n" ++ genDataDecls templ ++ "\n\n" ++ genBinary templ ++ "\n\n" ++ genCoding templ ++ "\n\n" ++ genTrusted templ ++ "\n\n" ++ genLength templ frontMatter = "{-| This module is automatically generated from the message template file. -}" ++ "module Network.Metaverse.PacketTypes where\n\n" ++ "import Control.Monad\n" ++ "import Data.Word\n" ++ "import Data.Int\n" ++ "import Data.Binary\n" ++ "import Data.Binary.Get\n" ++ "import Data.Binary.Put\n" ++ "import Data.Binary.IEEE754\n" ++ "import Data.UUID\n" ++ "import qualified Data.ByteString as B" genDataDecls templ = genPacketDecl templ ++ "\n\n" ++ genBlockTypes templ genPacketDecl templ = "data PacketBody\n\t= " ++ intercalate "\n\t| " (map packetCon (templateMessages templ)) ++ "\n\tderiving Show" where packetCon :: Message -> String packetCon msg = messageName msg ++ " " ++ intercalate " " (map packetParam (messageBlocks msg)) packetParam blk | blockQuantity blk == Single = "!" ++ blockDataName blk | otherwise = "![" ++ blockDataName blk ++ "]" genBlockTypes templ = intercalate "\n\n" (map blkData $ concatMap messageBlocks $ templateMessages templ) where blkData :: Block -> String blkData blk = "data " ++ (blockDataName blk) ++ " = " ++ (blockDataName blk) ++ " {\n\t" ++ intercalate ",\n\t" (map fldData (blockFields blk)) ++ "\n\t}" ++ "\n\tderiving Show" fldData :: Field -> String fldData fld = fieldRecord fld ++ " :: " ++ typeFrom (fieldType fld) typeFrom :: Type -> String typeFrom TypeNull = "!()" typeFrom (TypeFixed _) = "!B.ByteString" typeFrom (TypeVariable _) = "!B.ByteString" typeFrom TypeU8 = "!Word8" typeFrom TypeU16 = "!Word16" typeFrom TypeU32 = "!Word32" typeFrom TypeU64 = "!Word64" typeFrom TypeS8 = "!Int8" typeFrom TypeS16 = "!Int16" typeFrom TypeS32 = "!Int32" typeFrom TypeS64 = "!Int64" typeFrom TypeF32 = "!Float" typeFrom TypeF64 = "!Double" typeFrom TypeVector3 = "!(Float, Float, Float)" typeFrom TypeVector3d = "!(Double, Double, Double)" typeFrom TypeVector4 = "!(Float, Float, Float, Float)" typeFrom TypeQuaternion = "!(Float, Float, Float, Float)" typeFrom TypeUUID = "!UUID" typeFrom TypeBool = "!Bool" typeFrom TypeIPAddr = "![Word8]" typeFrom TypeIPPort = "!Word16" isFixed (Message { messageFrequency = Fixed _ }) = True isFixed _ = False isLow (Message { messageFrequency = Low _ }) = True isLow _ = False isMed (Message { messageFrequency = Medium _ }) = True isMed _ = False isHigh (Message { messageFrequency = High _ }) = True isHigh _ = False isLowOrFixed x = isLow x || isFixed x genBinary templ = "instance Binary PacketBody where\n" ++ intercalate "\n" (map encodeMessage (templateMessages templ)) ++ "\n" ++ "\tget = do\n" ++ "\t\tid1 <- getWord8\n" ++ "\t\tcase id1 of\n" ++ "\t\t\t0xff -> do\n" ++ "\t\t\t\tid2 <- getWord8\n" ++ "\t\t\t\tcase id2 of\n" ++ "\t\t\t\t\t0xff -> do\n" ++ "\t\t\t\t\t\tid3 <- getWord16be\n" ++ "\t\t\t\t\t\tcase id3 of\n" ++ intercalate "\n" (map ("\t\t\t\t\t\t\t" ++) (map decodeMessage (filter isLowOrFixed $ templateMessages templ))) ++ "\n" ++ "\t\t\t\t\t\t\t_ -> fail \"Unrecognized message number\"\n" ++ intercalate "\n" (map ("\t\t\t\t\t" ++) (map decodeMessage (filter isMed $ templateMessages templ))) ++ "\n" ++ "\t\t\t\t\t_ -> fail \"Unrecognized message number\"\n" ++ intercalate "\n" (map ("\t\t\t" ++) (map decodeMessage (filter isHigh $ templateMessages templ))) ++ "\n" ++ "\t\t\t_ -> fail \"Unrecognized message number\"\n" ++ "\n\n" ++ intercalate "\n\n" (map blkBinary $ concatMap messageBlocks $ templateMessages templ) encodeMessage msg = let bnames = take (length (messageBlocks msg)) names in "\tput (" ++ messageName msg ++ " " ++ intercalate " " bnames ++ ") = do " ++ msgNum msg ++ ";" ++ intercalate ";" (map putBlock (zip bnames (messageBlocks msg))) ++ ";" ++ "return ()" where msgNum (Message { messageFrequency = Fixed n }) = "putWord32be " ++ show n msgNum (Message { messageFrequency = Low n }) = "putWord32be " ++ show (0xffff0000 + n) msgNum (Message { messageFrequency = Medium n }) = "putWord16be " ++ show (0xff00 + n) msgNum (Message { messageFrequency = High n }) = "putWord8 " ++ show n putBlock (x, Block { blockQuantity = Single }) = "put " ++ x putBlock (x, Block { blockQuantity = Variable }) = "putWord8 (fromIntegral (length " ++ x ++ ")) ; mapM_ put " ++ x putBlock (x, Block { blockQuantity = Multiple _ }) = "mapM_ put " ++ x decodeMessage msg = let bnames = take (length (messageBlocks msg)) names in guard msg ++ " -> do " ++ intercalate ";" (map getBlock (zip bnames (messageBlocks msg))) ++ "; return (" ++ messageName msg ++ " " ++ intercalate " " bnames ++ ")" where guard (Message { messageFrequency = Fixed n }) = show (n - 0xffff0000) guard (Message { messageFrequency = Low n }) = show n guard (Message { messageFrequency = Medium n }) = show n guard (Message { messageFrequency = High n }) = show n getBlock (x, Block { blockQuantity = Single }) = x ++ " <- get" getBlock (x, Block { blockQuantity = Variable }) = x ++ "' <- getWord8 ; " ++ x ++ "<- replicateM (fromIntegral " ++ x ++ "') get" getBlock (x, Block { blockQuantity = Multiple n }) = x ++ " <- replicateM " ++ show n ++ " get" blkBinary blk = let bnames = take (length (blockFields blk)) names in "instance Binary " ++ blockDataName blk ++ " where\n" ++ "\tget = do " ++ intercalate ";" (map getField (zip names (blockFields blk))) ++ ";return (" ++ blockDataName blk ++ " " ++ (intercalate " " bnames) ++ ")\n" ++ "\tput x = do " ++ intercalate ";" (map putField (blockFields blk)) ++ ";return ()\n" where getField (x, Field { fieldType = TypeNull }) = x ++ " <- get" getField (x, Field { fieldType = TypeFixed n }) = x ++ " <- getBytes " ++ show n getField (x, Field { fieldType = TypeVariable 1 }) = x ++ "' <- getWord8 ; " ++ x ++ " <- getBytes (fromIntegral " ++ x ++ "')" getField (x, Field { fieldType = TypeVariable 2 }) = x ++ "' <- getWord16le ; " ++ x ++ " <- getBytes (fromIntegral " ++ x ++ "')" getField (x, Field { fieldType = TypeU8 }) = x ++ " <- getWord8" getField (x, Field { fieldType = TypeU16 }) = x ++ " <- getWord16le" getField (x, Field { fieldType = TypeU32 }) = x ++ " <- getWord32le" getField (x, Field { fieldType = TypeU64 }) = x ++ " <- getWord64le" getField (x, Field { fieldType = TypeS8 }) = x ++ " <- fmap fromIntegral getWord8" getField (x, Field { fieldType = TypeS16 }) = x ++ " <- fmap fromIntegral getWord16le" getField (x, Field { fieldType = TypeS32 }) = x ++ " <- fmap fromIntegral getWord32le" getField (x, Field { fieldType = TypeS64 }) = x ++ " <- fmap fromIntegral getWord64le" getField (x, Field { fieldType = TypeF32 }) = x ++ " <- getFloat32le" getField (x, Field { fieldType = TypeF64 }) = x ++ " <- getFloat64le" getField (x, Field { fieldType = TypeVector3 }) = x ++ "'1 <- getFloat32le ; " ++ x ++ "'2 <- getFloat32le ; " ++ x ++ "'3 <- getFloat32le ; " ++ "let {" ++ x ++ " = (" ++ x ++ "'1, " ++ x ++ "'2, " ++ x ++ "'3) }" getField (x, Field { fieldType = TypeVector3d }) = x ++ "'1 <- getFloat64le ; " ++ x ++ "'2 <- getFloat64le ; " ++ x ++ "'3 <- getFloat64le ; " ++ "let {" ++ x ++ " = (" ++ x ++ "'1, " ++ x ++ "'2, " ++ x ++ "'3) }" getField (x, Field { fieldType = TypeVector4 }) = x ++ "'1 <- getFloat32le ; " ++ x ++ "'2 <- getFloat32le ; " ++ x ++ "'3 <- getFloat32le ; " ++ x ++ "'4 <- getFloat32le ; " ++ "let {" ++ x ++ " = (" ++ x ++ "'1, " ++ x ++ "'2, " ++ x ++ "'3, " ++ x ++ "'4)}" getField (x, Field { fieldType = TypeQuaternion }) = x ++ "'1 <- getFloat32le ; " ++ x ++ "'2 <- getFloat32le ; " ++ x ++ "'3 <- getFloat32le ; " ++ "let {" ++ x ++ " = (" ++ x ++ "'1, " ++ x ++ "'2, " ++ x ++ "'3, " ++ "sqrt (abs (1 - " ++ x ++ "'1^2 - " ++ x ++ "'2^2 - " ++ x ++ "'3^2))) }" getField (x, Field { fieldType = TypeUUID }) = x ++ " <- get" getField (x, Field { fieldType = TypeBool }) = x ++ " <- get" getField (x, Field { fieldType = TypeIPAddr }) = x ++ " <- replicateM 4 getWord8" getField (x, Field { fieldType = TypeIPPort }) = x ++ " <- getWord16le" putField (Field { fieldRecord = rname, fieldType = TypeNull }) = "put (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeFixed n }) = "putByteString (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeVariable 1 }) = "putWord8 (fromIntegral $ B.length (" ++ rname ++ " x)) ; putByteString (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeVariable 2 }) = "putWord16le (fromIntegral $ B.length (" ++ rname ++ " x)) ; putByteString (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeU8 }) = "putWord8 (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeU16 }) = "putWord16le (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeU32 }) = "putWord32le (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeU64 }) = "putWord64le (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeS8 }) = "putWord8 (fromIntegral (" ++ rname ++ " x))" putField (Field { fieldRecord = rname, fieldType = TypeS16 }) = "putWord16le (fromIntegral (" ++ rname ++ " x))" putField (Field { fieldRecord = rname, fieldType = TypeS32 }) = "putWord32le (fromIntegral (" ++ rname ++ " x))" putField (Field { fieldRecord = rname, fieldType = TypeS64 }) = "putWord63le (fromIntegral (" ++ rname ++ " x))" putField (Field { fieldRecord = rname, fieldType = TypeF32 }) = "putFloat32le (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeF64 }) = "putFloat64le (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeVector3 }) = "(let (a,b,c) = " ++ rname ++ " x in putFloat32le a >> putFloat32le b >> putFloat32le c)" putField (Field { fieldRecord = rname, fieldType = TypeVector3d }) = "(let (a,b,c) = " ++ rname ++ " x in putFloat64le a >> putFloat64le b >> putFloat64le c)" putField (Field { fieldRecord = rname, fieldType = TypeVector4 }) = "(let (a,b,c,d) = " ++ rname ++ " x in putFloat32le a >> putFloat32le b >> putFloat32le c >> putFloat32le d)" putField (Field { fieldRecord = rname, fieldType = TypeQuaternion }) = "(let (a,b,c,d) = " ++ rname ++ " x in putFloat32le a >> putFloat32le b >> putFloat32le c)" putField (Field { fieldRecord = rname, fieldType = TypeUUID }) = "put (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeBool }) = "put (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeIPAddr }) = "mapM_ put (" ++ rname ++ " x)" putField (Field { fieldRecord = rname, fieldType = TypeIPPort }) = "putWord16le (" ++ rname ++ " x)" names = map (('x':) . show) [1..] genCoding templ = "shouldZerocode :: PacketBody -> Bool\n" ++ intercalate "\n" (map f (templateMessages templ)) where f msg = "shouldZerocode (" ++ messageName msg ++ " " ++ intercalate " " (replicate (length (messageBlocks msg)) "_") ++ ") = " ++ show (messageZerocoded msg) genTrusted templ = "isTrusted :: PacketBody -> Bool\n" ++ intercalate "\n" (map f (templateMessages templ)) where f msg = "isTrusted (" ++ messageName msg ++ " " ++ intercalate " " (replicate (length (messageBlocks msg)) "_") ++ ") = " ++ show (messageTrusted msg) genLength templ = "packetLength :: PacketBody -> Int\n" ++ intercalate "\n" (map f (templateMessages templ)) where f msg = let (bnames, names') = splitAt (length (messageBlocks msg)) names in "packetLength (" ++ messageName msg ++ " " ++ intercalate " " bnames ++ ") = " ++ show (msgNumLen msg) ++ concatMap (blockLen names') (zip bnames (messageBlocks msg)) msgNumLen msg | isLowOrFixed msg = 4 | isMed msg = 2 | isHigh msg = 1 blockLen names' (x, blk@(Block { blockQuantity = Single })) = " + (" ++ blockBodyLen names' blk ++ ") " ++ x blockLen names' (x, blk@(Block { blockQuantity = Multiple _ })) = " + sum (map (" ++ blockBodyLen names' blk ++ ") " ++ x ++ ")" blockLen names' (x, blk@(Block { blockQuantity = Variable })) = " + 1 + sum (map (" ++ blockBodyLen names' blk ++ ") " ++ x ++ ")" blockBodyLen names' blk = let fnames = take (length (blockFields blk)) names' in "\\(" ++ blockDataName blk ++ " " ++ intercalate " " fnames ++ ") -> " ++ show (sum (map (typeLen . fieldType) (blockFields blk))) ++ concatMap varType (zip fnames (blockFields blk)) typeLen TypeNull = 0 ; typeLen (TypeFixed n) = n typeLen (TypeVariable n) = n ; typeLen TypeU8 = 1 typeLen TypeU16 = 2 ; typeLen TypeU32 = 4 typeLen TypeU64 = 8 ; typeLen TypeS8 = 1 typeLen TypeS16 = 2 ; typeLen TypeS32 = 4 typeLen TypeS64 = 8 ; typeLen TypeF32 = 4 typeLen TypeF64 = 8 ; typeLen TypeVector3 = 12 typeLen TypeVector3d = 24 ; typeLen TypeVector4 = 16 typeLen TypeQuaternion = 12 ; typeLen TypeUUID = 16 typeLen TypeBool = 1 ; typeLen TypeIPAddr = 4 typeLen TypeIPPort = 2 varType (x, Field { fieldType = TypeVariable _ }) = " + B.length " ++ x varType _ = "" ----------------------------------------------------------------------------- template2hs infile outfile _ = do text <- readFile infile case parse template infile text of Left err -> error (show err) Right templ -> do writeFile outfile (genSource templ)