mvclient-0.2: BuildTools/Template2Hs.hs
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)