amqp-0.24.0: Tools/Builder.hs
{-# LANGUAGE BangPatterns #-}
--reads the AMQP xml spec file and builds the "Generated.hs" module
--this is pretty much a BIG HACK
import Data.Char
import Data.Maybe
import Text.XML.Light
import qualified Data.Map as M
import qualified Data.List as L
data Class = Class String Int [Method] [Field] --className, classID, methods, content-fields
deriving Show
data Method = Method String Int [Field] --methodName, methodID, fields
deriving Show
data Field = TypeField String String --fieldName, fieldType
| DomainField String String --fieldName, domainName
deriving Show
fieldType :: M.Map String String -> Field -> String
fieldType _ (TypeField _ x) = x
fieldType domainMap (DomainField _ domain) = fromJust $ M.lookup domain domainMap
main :: IO ()
main = do
spec <- readFile "amqp0-9-1.xml"
let parsed = parseXML spec
let !(Elem e) = parsed!!2
-- read domains
let domains = findChildren (unqual "domain") e
--map from domainName => type
let domainMap = M.fromList $ map readDomain domains
-- read classes
let classes = map readClass $ findChildren (unqual "class") e :: [Class]
-- generate data declaration
let dataDecl = "data MethodPayload = \n" ++ (concat $ L.intersperse " |" $ concatMap (writeDataDeclForClass domainMap) classes) ++ "\n deriving Show"
-- generate binary instances for data-type
let binaryGetInst = concat $ map (" "++) $ concatMap (writeBinaryGetInstForClass domainMap) classes
let binaryPutInst = concat $ map (" "++) $ concatMap (writeBinaryPutInstForClass domainMap) classes
-- generate content types
let contentHeaders = concat $ L.intersperse " |" $ map (writeContentHeaderForClass domainMap) classes
let contentHeadersGetInst = concatMap writeContentHeaderGetInstForClass classes
let contentHeadersPutInst = concatMap writeContentHeaderPutInstForClass classes
let contentHeadersClassIDs = concatMap writeContentHeaderClassIDsForClass classes
writeFile "Generated.hs" (
"module Network.AMQP.Generated where\n\n" ++
"import Data.Binary\n" ++
"import Data.Binary.Get\n" ++
"import Data.Binary.Put\n" ++
"import Data.Bits\n" ++
"import Data.Maybe\n" ++
"import Network.AMQP.Types\n\n" ++
"getContentHeaderProperties :: ShortInt -> Get ContentHeaderProperties" ++ "\n" ++
contentHeadersGetInst ++ "\n" ++
"getContentHeaderProperties n = error (\"Unexpected content header properties: \" ++ show n)" ++ "\n" ++
"putContentHeaderProperties :: ContentHeaderProperties -> Put" ++ "\n" ++
contentHeadersPutInst ++ "\n" ++
"getClassIDOf :: ContentHeaderProperties -> ShortInt" ++ "\n" ++
contentHeadersClassIDs ++ "\n" ++
"data ContentHeaderProperties = \n " ++
contentHeaders ++
"\n deriving Show\n\n" ++
"--Bits need special handling because AMQP requires contiguous bits to be packed into a Word8\n" ++
"-- | Packs up to 8 bits into a Word8\n" ++
"putBits :: [Bit] -> Put\n" ++
"putBits = putWord8 . putBits' 0\n" ++
"putBits' :: Int -> [Bit] -> Word8\n" ++
"putBits' _ [] = 0\n" ++
"putBits' offset (x:xs) = (shiftL (toInt x) offset) .|. (putBits' (offset+1) xs)\n" ++
" where toInt True = 1\n" ++
" toInt False = 0\n" ++
"getBits :: Int -> Get [Bit]\n" ++
"getBits num = getWord8 >>= return . getBits' num 0\n" ++
"getBits' :: Int -> Int -> Word8 -> [Bit]\n" ++
"getBits' 0 _ _ = []\n" ++
"getBits' num offset x = ((x .&. (2^offset)) /= 0) : (getBits' (num-1) (offset+1) x)\n" ++
"-- | Packs up to 15 Bits into a Word16 (=Property Flags) \n" ++
"putPropBits :: [Bit] -> Put\n" ++
"putPropBits = putWord16be . putPropBits' 0\n" ++
"putPropBits' :: Int -> [Bit] -> Word16\n" ++
"putPropBits' _ [] = 0\n" ++
"putPropBits' offset (x:xs) = (shiftL (toInt x) (15-offset)) .|. (putPropBits' (offset+1) xs)\n" ++
" where toInt True = 1\n" ++
" toInt False = 0\n" ++
"getPropBits :: Int -> Get [Bit]\n" ++
"getPropBits num = getWord16be >>= return . getPropBits' num 0\n" ++
"getPropBits' :: Int -> Int -> Word16 -> [Bit]\n" ++
"getPropBits' 0 _ _ = []\n" ++
"getPropBits' num offset x = ((x .&. (2^(15-offset))) /= 0) : (getPropBits' (num-1) (offset+1) x)\n"++
"condGet :: Binary a => Bool -> Get (Maybe a)\n" ++
"condGet False = return Nothing\n" ++
"condGet True = get >>= return . Just\n\n" ++
"condPut :: Binary a => Maybe a -> Put\n" ++
"condPut = maybe (return ()) put\n" ++
"instance Binary MethodPayload where\n" ++
-- put instances
binaryPutInst ++
-- get instances
" get = do\n" ++
" classID <- getWord16be\n" ++
" methodID <- getWord16be\n" ++
" case (classID, methodID) of\n" ++
binaryGetInst ++
" x -> error (\"Unexpected classID and methodID: \" ++ show x)" ++ "\n" ++
-- data declaration
dataDecl)
translateType :: String -> String
translateType "octet" = "Octet"
translateType "longstr" = "LongString"
translateType "shortstr" = "ShortString"
translateType "short" = "ShortInt"
translateType "long" = "LongInt"
translateType "bit" = "Bit"
translateType "table" = "FieldTable"
translateType "longlong" = "LongLongInt"
translateType "timestamp" = "Timestamp"
translateType x = error x
fixClassName :: String -> String
fixClassName s = (toUpper $ head s) : (tail s)
fixMethodName :: String -> String
fixMethodName s = map f s
where
f '-' = '_'
f x = x
fixFieldName :: String -> String
fixFieldName "type" = "typ"
fixFieldName s = map f s
where
f ' ' = '_'
f x = x
---- data declaration ----
writeDataDeclForClass :: M.Map String String -> Class -> [String]
writeDataDeclForClass domainMap (Class nam _ methods _) =
map ("\n " ++) $ map (writeDataDeclForMethod domainMap nam) methods
writeDataDeclForMethod :: M.Map String String -> String -> Method -> String
writeDataDeclForMethod domainMap className (Method nam _ fields) =
let fullName = (fixClassName className) ++ "_" ++ (fixMethodName nam) in
--data type declaration
(writeTypeDecl domainMap fullName fields)
--binary instances
--(writeBinaryInstance fullName fields)
writeTypeDecl :: M.Map String String -> String -> [Field] -> String
writeTypeDecl domainMap fullName fields =
fullName ++ "\n " ++ (concat $ L.intersperse "\n " $ map writeF fields) ++ "\n"
where
writeF (TypeField nam typ) = (translateType typ) ++ " -- " ++ (fixFieldName nam)
writeF f@(DomainField nam _) = (translateType $ fieldType domainMap f) ++ " -- " ++ (fixFieldName nam)
---- binary get instance ----
writeBinaryGetInstForClass :: M.Map String String -> Class -> [String]
writeBinaryGetInstForClass domainMap (Class nam index methods _) =
map (writeBinaryGetInstForMethod domainMap nam index) methods
writeBinaryGetInstForMethod :: M.Map String String -> String -> Int -> Method -> String
writeBinaryGetInstForMethod domainMap className classIndex (Method nam index fields) =
let fullName = (fixClassName className) ++ "_" ++ (fixMethodName nam) in
--binary instances
" " ++ (writeBinaryGetInstance domainMap fullName classIndex index fields)
writeBinaryGetInstance :: M.Map String String -> String -> Int -> Int -> [Field] -> String
writeBinaryGetInstance domainMap fullName classIndex methodIndex fields =
" (" ++ (show classIndex) ++ "," ++ (show methodIndex) ++ ") -> " ++ getDef ++ "\n"
where
manyLetters = map (:[]) ['a'..'z']
fieldTypes :: [(String,String)] --(a..z, fieldType)
fieldTypes = zip manyLetters $ map (fieldType domainMap) fields
--consecutive BITS have to be merged into a Word8
--TODO: more than 8bits have to be split into several Word8
grouped :: [ [(String, String)] ]
grouped = L.groupBy (\(_,x) (_,y) -> x=="bit" && y=="bit") fieldTypes
--concatMap (\x -> " get >>= \\" ++ x ++ " ->") (take (length fields) manyLetters)
showBlob xs | length xs == 1 = "get >>= \\" ++ (fst $ xs!!0) ++ " -> "
showBlob xs = "getBits " ++ (show $ length xs) ++ " >>= \\[" ++ (concat $ L.intersperse "," $ map fst xs) ++ "] -> "
getStmt = concatMap showBlob grouped
getDef =
let wrap = if (length fields) /= 0 then ("("++) . (++")") else id
in
getStmt
++ " return "
++ wrap (fullName ++ concatMap (" "++) (take (length fields) manyLetters))
---- binary put instance ----
writeBinaryPutInstForClass :: M.Map String String -> Class -> [String]
writeBinaryPutInstForClass domainMap (Class nam index methods _) =
map (writeBinaryPutInstForMethod domainMap nam index) methods
writeBinaryPutInstForMethod :: M.Map String String -> String -> Int -> Method -> String
writeBinaryPutInstForMethod domainMap className classIndex (Method nam index fields) =
let fullName = (fixClassName className) ++ "_" ++ (fixMethodName nam) in
--binary instances
(writeBinaryPutInstance domainMap fullName classIndex index fields)
writeBinaryPutInstance :: M.Map String String -> String -> Int -> Int -> [Field] -> String
writeBinaryPutInstance domainMap fullName classIndex methodIndex fields =
putDef ++ "\n"
where
manyLetters = map (:[]) ['a'..'z']
fieldTypes :: [(String,String)] --(a..z, fieldType)
fieldTypes = zip manyLetters $ map (fieldType domainMap) fields
--consecutive BITS have to be merged into a Word8
--TODO: more than 8bits have to be split into several Word8
grouped :: [ [(String, String)] ]
grouped = L.groupBy (\(_,x) (_,y) -> x=="bit" && y=="bit") fieldTypes
showBlob xs | length xs == 1 = " >> put " ++ (fst $ xs!!0)
showBlob xs = " >> putBits [" ++ (concat $ L.intersperse "," $ map fst xs) ++ "]"
putStmt = concatMap showBlob grouped
putDef =
let wrap = if (length fields) /= 0 then ("("++) . (++")") else id
pattern = fullName ++ concatMap (' ':) (take (length fields) manyLetters)
in
"put " ++ wrap pattern ++" = "
++ "putWord16be " ++ (show classIndex) ++ " >> putWord16be " ++ (show methodIndex)
++ putStmt
---- content header declaration ----
writeContentHeaderForClass :: M.Map String String -> Class -> String
writeContentHeaderForClass domainMap (Class nam _ _ fields) =
let fullName = "CH" ++ (fixClassName nam) in
(writeContentHeaderDecl domainMap fullName fields)
writeContentHeaderDecl :: M.Map String String -> String -> [Field] -> String
writeContentHeaderDecl domainMap fullName fields =
fullName ++ "\n " ++ (concat $ L.intersperse "\n " $ map writeF fields) ++ "\n"
where
writeF (TypeField nam typ) = "(Maybe " ++ (translateType typ) ++ ") -- " ++ (fixFieldName nam)
writeF f@(DomainField nam _) = "(Maybe " ++ (translateType $ fieldType domainMap f) ++ ") -- " ++ (fixFieldName nam)
---- contentheader get instance ----
writeContentHeaderGetInstForClass :: Class -> String
writeContentHeaderGetInstForClass (Class nam index _ fields) =
let fullName = "CH" ++ (fixClassName nam) in
--binary instances
(writeContentHeaderGetInstance fullName index fields)
writeContentHeaderGetInstance :: String -> Int -> [Field] -> String
writeContentHeaderGetInstance fullName classIndex fields =
"getContentHeaderProperties " ++ (show classIndex) ++ " = " ++ getDef ++ "\n"
where
manyLetters = map (:[]) ['a'..'z']
usedLetters = take (length fields) manyLetters
showBlob x = "condGet " ++ x ++ " >>= \\" ++ x ++ "' -> "
getStmt = concatMap showBlob usedLetters
getDef =
let wrap = if (length fields) /= 0 then ("("++) . (++")") else id
in
"getPropBits " ++ (show $ length fields) ++ " >>= \\[" ++ (concat $ L.intersperse "," usedLetters ) ++ "] -> " ++
getStmt
++ " return "
++ wrap (fullName ++ " " ++ concatMap (++"' ") (take (length fields) usedLetters))
---- contentheader put instance ----
writeContentHeaderPutInstForClass :: Class -> String
writeContentHeaderPutInstForClass (Class nam _ _ fields) =
let fullName = "CH" ++ (fixClassName nam) in
--binary instances
(writeContentHeaderPutInstance fullName fields)
writeContentHeaderPutInstance :: String -> [Field] -> String
writeContentHeaderPutInstance fullName fields =
"putContentHeaderProperties " ++ putDef ++ "\n"
where
manyLetters = map (:[]) ['a'..'z']
usedLetters = take (length fields) manyLetters
showBlob x = " >> condPut " ++ x
putStmt = concatMap showBlob usedLetters
putDef =
let wrap = if (length fields) /= 0 then ("("++) . (++")") else id
pattern = fullName ++ concatMap (' ':) (take (length fields) manyLetters)
in
wrap pattern ++" = "
++ "putPropBits " ++ "[" ++ (concat $ L.intersperse "," $ map ("isJust " ++ ) usedLetters) ++ "] "
++ putStmt
---- contentheader class ids -----
writeContentHeaderClassIDsForClass :: Class -> String
writeContentHeaderClassIDsForClass (Class nam index _ fields) =
let fullName = "CH" ++ (fixClassName nam) in
--binary instances
(writeContentHeaderClassIDsInstance fullName index fields)
writeContentHeaderClassIDsInstance :: String -> Int -> [Field] -> String
writeContentHeaderClassIDsInstance fullName classIndex fields =
"getClassIDOf (" ++ fullName ++ (concat $replicate (length fields) " _") ++ ") = " ++ (show classIndex) ++ "\n"
readDomain :: Element -> (String, String)
readDomain d =
let (Just domainName) = lookupAttr (unqual "name") $ elAttribs d
(Just typ) = lookupAttr (unqual "type") $ elAttribs d
in (domainName, typ)
readClass :: Element -> Class
readClass c =
let (Just className) = lookupAttr (unqual "name") $ elAttribs c
(Just classIndex) = lookupAttr (unqual "index") $ elAttribs c
methods = map readMethod $ findChildren (unqual "method") c
fields = map readField $ findChildren (unqual "field") c
in Class className (read classIndex) methods fields
readMethod :: Element -> Method
readMethod m =
let (Just methodName) = lookupAttr (unqual "name") $ elAttribs m
(Just methodIndex) = lookupAttr (unqual "index") $ elAttribs m
fields = map readField $ findChildren (unqual "field") m
in Method methodName (read methodIndex) fields
readField :: Element -> Field
readField f =
let (Just fieldName) = lookupAttr (unqual "name") $ elAttribs f
fType = lookupAttr (unqual "type") $ elAttribs f
fDomain = lookupAttr (unqual "domain") $ elAttribs f in
case (fType, fDomain) of
(Just t, _) -> TypeField fieldName t
(_, Just d) -> DomainField fieldName d
_ -> error ("Missing field type and domain attributes")