module Codec.Libevent.Generate (generate) where
import System.Environment (getArgs)
import Data.Char (toUpper)
import Data.List (intersperse)
import Data.Maybe (mapMaybe)
import Text.Printf (printf)
import Codec.Libevent.Parse
generate :: String
-> RPCFile
-> IO ()
generate modulename rpcfile = do
printf "module %s where\n\n" modulename
putStr "import Codec.Libevent\nimport Data.Word\n\n"
putStr "import qualified Data.IntSet as IS\n\n"
putStr "import Data.Binary.Put\nimport Data.Binary.Strict.Get\n\n"
putStr "import qualified Data.ByteString as BS\n"
putStr "import qualified Data.ByteString.Lazy as BSL\n\n"
putStr "import Codec.Libevent.Class\n"
sequence $ map generateStruct $ rpcstructs rpcfile
putStr "\n"
return ()
toDataName :: String -> String
toDataName (first:rest) = (toUpper first) : rest
rpcTypeToTypeString Int = "Word32"
rpcTypeToTypeString VarBytes = "BS.ByteString"
rpcTypeToTypeString String = "String"
rpcTypeToTypeString (Bytes _) = "BS.ByteString"
rpcTypeToTypeString (Struct name) = toDataName name
typeString :: Presence -> Type -> String
typeString Required x = rpcTypeToTypeString x
typeString Optional x = printf "Maybe %s" $ rpcTypeToTypeString x
typeString Repeated x = printf "[%s]" $ rpcTypeToTypeString x
generateElem :: String -> RPCElem -> String
generateElem structname elem =
printf "%s_%s :: %s" structname (elemname elem) typestring where
typestring = typeString (elempresence elem) (elemtype elem)
generateSerialiseElem :: String -> RPCElem -> String
generateSerialiseElem structname elem@(RPCElem { elempresence = Required }) =
generateSerialiseElem' structname elem var where
var :: String
var = printf "%s_%s x" structname (elemname elem)
generateSerialiseElem structname elem@(RPCElem { elempresence = Optional }) =
printf "case (%s x) of\n Nothing -> return ()\n (Just x) -> %s" a b where
a :: String
a = printf "%s_%s" structname (elemname elem)
b = generateSerialiseElem' structname elem "x"
generateSerialiseElem structname elem@(RPCElem { elempresence = Repeated }) =
printf "sequence $ map (\\x -> %s) $ %s x" a b where
a = generateSerialiseElem' structname elem "x"
b :: String
b = printf "%s_%s" structname (elemname elem)
generateSerialiseElem' :: String -> RPCElem -> String -> String
generateSerialiseElem' structname elem@(RPCElem { elemtype = Bytes n }) var =
printf "if (BS.length (%s)) /= %d then error \"Bad length for %s while serialising a %s\" else putTaggedVarBytes %d (%s)" var n (elemname elem) dataname tag var where
dataname = toDataName structname
tag = elemtag elem
generateSerialiseElem' structname elem@(RPCElem { elemtype = VarBytes }) var =
printf "putTaggedVarBytes %d (%s)" (elemtag elem) var
generateSerialiseElem' structname elem@(RPCElem { elemtype = Int }) var =
printf "putTaggedWord32 %d (%s)" (elemtag elem) var
generateSerialiseElem' structname elem@(RPCElem { elemtype = String }) var =
printf "putTaggedString %d (%s)" (elemtag elem) var
generateSerialiseElem' structname elem@(RPCElem { elemtype = Struct struct }) var =
printf "putTaggedVarBytes %d $ %sSerialiseBS (%s)" (elemtag elem) struct var
defaultValue :: RPCElem -> String
defaultValue (RPCElem { elempresence = Optional }) = "Nothing"
defaultValue (RPCElem { elempresence = Repeated }) = "[]"
defaultValue (RPCElem { elemtype = String }) = "\"\""
defaultValue (RPCElem { elemtype = Int }) = "0"
defaultValue (RPCElem { elemtype = Bytes _ }) = "BS.empty"
defaultValue (RPCElem { elemtype = VarBytes }) = "BS.empty"
defaultValue (RPCElem { elemtype = Struct n }) = printf "%sEmpty" n
requiredTags :: [RPCElem] -> [Integer]
requiredTags = mapMaybe f where
f (RPCElem { elempresence = Required, elemtag = tag }) = Just tag
f _ = Nothing
wrapValue structname elem@(RPCElem { elempresence = Required }) objectname valuename =
valuename
wrapValue structname elem@(RPCElem { elempresence = Optional }) objectname valuename =
printf "(Just %s)" valuename
wrapValue structname elem@(RPCElem { elempresence = Repeated }) objectname valuename =
printf "(%s : %s_%s %s)" valuename structname (elemname elem) objectname
generateDeserialise :: String -> RPCElem -> String
generateDeserialise name elem@(RPCElem { elemtype = Int }) =
printf " %d -> getWord8 >> getLengthPrefixed >>= (\\v -> f (o { %s_%s = %s }) (IS.insert %d set))"
tag name (elemname elem) (wrapValue name elem "o" "v") tag where
tag = elemtag elem
generateDeserialise name elem@(RPCElem { elemtype = String }) =
printf " %d -> getLengthPrefixed >>= getByteString . fromIntegral >>= (\\v -> f (o { %s_%s = %s }) (IS.insert %d set))"
tag name (elemname elem) (wrapValue name elem "o" "(decodeString v)") tag where
tag = elemtag elem
generateDeserialise name elem@(RPCElem { elemtype = VarBytes }) =
printf " %d -> getLengthPrefixed >>= getByteString . fromIntegral >>= (\\v -> f (o { %s_%s = %s }) (IS.insert %d set))"
tag name (elemname elem) (wrapValue name elem "o" "v") tag where
tag = elemtag elem
generateDeserialise name elem@(RPCElem { elemtype = Bytes n }) =
printf " %d -> getLengthPrefixed >>= getByteString . fromIntegral >>= (\\v -> if (BS.length v) /= %d then fail \"bytes element had incorrect length decoding %s\" else f (o { %s_%s = %s }) (IS.insert %d set))"
tag n (toDataName name) name (elemname elem) (wrapValue name elem "o" "v") tag where
tag = elemtag elem
generateDeserialise name elem@(RPCElem { elemtype = Struct struct }) =
printf " %d -> getLengthPrefixed >>= getByteString . fromIntegral >>= (\\v -> case (%sDeserialiseBS v) of { Left err -> fail (\"Failed to deserialse %s: \" ++ err) ; Right result -> f (o {%s_%s = %s }) (IS.insert %d set) })" (elemtag elem) struct (toDataName name) name (elemname elem) (wrapValue name elem "o" "result") (elemtag elem)
generateStruct (RPCStruct { structname = name, structelems = elems }) = do
let dataname = toDataName name
printf "data %s = %s { " dataname dataname
putStr $ concat $ intersperse ", " $ map (generateElem name) elems
putStr " } deriving (Show, Eq)\n\n"
printf "%sSerialise :: %s -> Put\n" name dataname
printf "%sSerialise x = do\n" name
putStr " "
putStr $ concat $ intersperse "\n " $ map (generateSerialiseElem name) elems
putStr "\n\n"
printf "%sSerialiseBS = BS.concat . BSL.toChunks . runPut . %sSerialise\n\n" name name
printf "%sEmpty = %s %s" name dataname $ concat $ intersperse " " $ map defaultValue elems
putStr "\n\n"
printf "%sRequiredElementsSet = IS.fromList %s\n\n" name $ show $ requiredTags elems
printf "%sDeserialise :: Get %s\n" name dataname
printf "%sDeserialise = f %sEmpty IS.empty where\n" name name
putStr " f o set = do\n"
putStr " emptyp <- isEmpty\n"
putStr " if emptyp\n"
printf " then if not (IS.isSubsetOf %sRequiredElementsSet set)\n" name
printf " then fail \"%s did not contain all required elements\"\n" dataname
putStr " else return o\n"
putStr " else do tag <- getBase128\n"
putStr " case tag of\n"
putStr $ concat $ intersperse "\n" $ map (generateDeserialise name) elems
putStr "\n"
putStr " otherwise -> getLengthPrefixed >>= getByteString . fromIntegral >> f o set\n"
putStr "\n\n"
printf "%sDeserialiseBS = fst . runGet %sDeserialise\n" name name
putStr "\n"
printf "instance TaggedStructure %s where\n" dataname
printf " empty = %sEmpty\n" name
printf " serialise = %sSerialiseBS\n" name
printf " deserialise = %sDeserialiseBS\n" name
putStr "\n"