Generate.hs

-- |
-- Module: Codec.Libevent.Generate
-- Copyright: Adam Langley 2007
-- License: BSD
--
-- This module generates Haskell code for serialising and deserialising
-- libevent tagged data structures, as implemented in libevent-1.4.0-beta.
--
-- A single .rpc file (containing one or more structures) is mapped to a single
-- Haskell file. Take this example:
--
-- > struct test {
-- >   required int a = 1;
-- >   optional string b = 2;
-- >   repeated struct[test2] c = 3;
-- > }
--
-- This will result in a data decl for 'Test', having named members:
-- test_a, test_b and test_c. Required elements are simple, optional
-- elements are wrapped in a Maybe and repeated elements in a list.
--
-- Types are mapped thus:
--
--    * int -> Word32
--
--    * string -> String
--
--    * bytes -> ByteString (strict)
--
--    * bytes[n] -> ByteString (with runtime checks on the size)
--
--    * struct[name] -> Name (the struct must be defined in the same file)
--
-- In the example above, @test2@ is required to be in the same .rpc file.
--
-- For a structure named @test@, the following would also be generated:
--
--   * @testEmpty@ - a Test filled with default values
--
--   * @testDeserialise@ - a strict Get instance to deserialise a test. Note
--     that these structures are self-deliminating, so additional garbage at
--     the end will be consumed and will probably result in an error
--
--   * @testDeserialiseBS@ - a function with type
--     ByteString -> Either String Test where the String is an error message
--
--   * @testSerialise@ - a Put Test function. Again, recall that these
--     structures aren't self deliminating
--
--   * @testSerialiseBS@ - a function with type Test -> ByteString
--
-- Each structure will also be an instance of the @TaggedStructure@ class
-- that you can find in "Codec.Libevent.Class"
--
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 the Haskell code for the given RPC file and write to standard
--   out. The generated module will export everything and takes the given
--   name
generate :: String  -- ^ the name of the module in the output
         -> RPCFile  -- ^ the RPC file to generate code for
         -> 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 ()

-- | Convert a struct name to a Haskell type name by uppercasing the first
--   letter
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

-- | Return the default value for a given type as a string
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

-- | Return a list of tag numbers which are required elements
requiredTags :: [RPCElem] -> [Integer]
requiredTags = mapMaybe f where
  f (RPCElem { elempresence = Required, elemtag = tag }) = Just tag
  f _ = Nothing

-- | Generate the code to add the given variable (called @valuename)
--   to an object (called @objectname).
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"