xcffib (empty) → 0.1.5
raw patch · 8 files changed
+1019/−0 lines, 8 filesdep +HUnitdep +attoparsecdep +basesetup-changed
Dependencies added: HUnit, attoparsec, base, bytestring, containers, directory, filemanip, filepath, language-python, mtl, optparse-applicative, split, test-framework, test-framework-hunit, xcb-types, xcffib
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- generator/Data/XCB/Python/Parse.hs +614/−0
- generator/Data/XCB/Python/PyHelpers.hs +167/−0
- generator/xcffibgen.hs +51/−0
- tests/GeneratorTests.hs +55/−0
- tests/PyHelpersTests.hs +34/−0
- xcffib.cabal +75/−0
+ LICENSE view
@@ -0,0 +1,21 @@+// MIT++Copyright (c) 2014 Tycho Andersen++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ generator/Data/XCB/Python/Parse.hs view
@@ -0,0 +1,614 @@+{-# LANGUAGE ViewPatterns #-}+module Data.XCB.Python.Parse (+ parseXHeaders,+ xform,+ renderPy,+ calcsize+ ) where++import Control.Applicative hiding (getConst)+import Control.Monad.State.Strict++import Data.Attoparsec.ByteString.Char8+import Data.Bits+import qualified Data.ByteString.Char8 as BS+import Data.Either+import Data.List+import qualified Data.Map as M+import Data.Tree+import Data.Maybe+import Data.XCB.FromXML+import Data.XCB.Types as X+import Data.XCB.Python.PyHelpers++import Language.Python.Common as P++import System.FilePath+import System.FilePath.Glob++import Text.Printf++data TypeInfo =+ -- | A "base" X type, i.e. one described in baseTypeInfo; first arg is the+ -- struct.unpack string, second is the size.+ BaseType String |+ -- | A composite type, i.e. a Struct or Union created by XCB. First arg is+ -- the extension that defined it, second is the name of the type, third arg+ -- is the size if it is known.+ CompositeType String String+ deriving (Eq, Ord, Show)++type TypeInfoMap = M.Map X.Type TypeInfo++data BindingPart =+ Request (Statement ()) (Suite ()) |+ Declaration (Suite ()) |+ Noop+ deriving (Show)++collectBindings :: [BindingPart] -> (Suite (), Suite ())+collectBindings = foldr collectR ([], [])+ where+ collectR :: BindingPart -> (Suite (), Suite ()) -> (Suite (), Suite ())+ collectR (Request def decl) (defs, decls) = (def : defs, decl ++ decls)+ collectR (Declaration decl) (defs, decls) = (defs, decl ++ decls)+ collectR Noop x = x++parseXHeaders :: FilePath -> IO [XHeader]+parseXHeaders fp = do+ files <- namesMatching $ fp </> "*.xml"+ fromFiles files++renderPy :: Suite () -> String+renderPy s = ((intercalate "\n") $ map prettyText s) ++ "\n"++-- | Generate the code for a set of X headers. Note that the code is generated+-- in dependency order, NOT in the order you pass them in. Thus, you get a+-- string (a suggested filename) along with the python code for that XHeader+-- back.+xform :: [XHeader] -> [(String, Suite ())]+xform = map buildPython . dependencyOrder+ where+ buildPython :: Tree XHeader -> (String, Suite ())+ buildPython forest =+ let forest' = (mapM processXHeader $ postOrder forest)+ results = evalState forest' baseTypeInfo+ in last results+ processXHeader :: XHeader+ -> State TypeInfoMap (String, Suite ())+ processXHeader header = do+ let imports = [mkImport "xcffib", mkImport "struct", mkImport "six"]+ version = mkVersion header+ key = maybeToList $ mkKey header+ globals = [mkDict "_events", mkDict "_errors"]+ name = xheader_header header+ add = [mkAddExt header]+ parts <- mapM (processXDecl name) $ xheader_decls header+ let (requests, decls) = collectBindings parts+ ext = if length requests > 0+ then [mkClass (name ++ "Extension") "xcffib.Extension" requests]+ else []+ return $ (name, concat [imports, version, key, globals, decls, ext, add])+ -- Rearrange the headers in dependency order for processing (i.e. put+ -- modules which import others after the modules they import, so typedefs+ -- are propogated appropriately).+ dependencyOrder :: [XHeader] -> Forest XHeader+ dependencyOrder headers = unfoldForest unfold $ map xheader_header headers+ where+ headerM = M.fromList $ map (\h -> (xheader_header h, h)) headers+ unfold s = let h = headerM M.! s in (h, deps h)+ deps :: XHeader -> [String]+ deps = catMaybes . map matchImport . xheader_decls+ matchImport :: XDecl -> Maybe String+ matchImport (XImport n) = Just n+ matchImport _ = Nothing+ postOrder :: Tree a -> [a]+ postOrder (Node e cs) = (concat $ map postOrder cs) ++ [e]+++mkAddExt :: XHeader -> Statement ()+mkAddExt (xheader_header -> "xproto") =+ flip StmtExpr () $ mkCall "xcffib._add_core" [ mkName "xprotoExtension"+ , mkName "Setup"+ , mkName "_events"+ , mkName "_errors"+ ]+mkAddExt header =+ let name = xheader_header header+ in flip StmtExpr () $ mkCall "xcffib._add_ext" [ mkName "key"+ , mkName (name ++ "Extension")+ , mkName "_events"+ , mkName "_errors"+ ]++-- | Information on basic X types.+baseTypeInfo :: TypeInfoMap+baseTypeInfo = M.fromList $+ [ (UnQualType "CARD8", BaseType "B")+ , (UnQualType "uint8_t", BaseType "B")+ , (UnQualType "CARD16", BaseType "H")+ , (UnQualType "uint16_t", BaseType "H")+ , (UnQualType "CARD32", BaseType "I")+ , (UnQualType "uint32_t", BaseType "I")+ , (UnQualType "CARD64", BaseType "Q")+ , (UnQualType "uint64_t", BaseType "Q")+ , (UnQualType "INT8", BaseType "b")+ , (UnQualType "int8_t", BaseType "b")+ , (UnQualType "INT16", BaseType "h")+ , (UnQualType "int16_t", BaseType "h")+ , (UnQualType "INT32", BaseType "i")+ , (UnQualType "int32_t", BaseType "i")+ , (UnQualType "INT64", BaseType "q")+ , (UnQualType "uint64_t", BaseType "q")+ , (UnQualType "BYTE", BaseType "B")+ , (UnQualType "BOOL", BaseType "B")+ , (UnQualType "char", BaseType "c")+ , (UnQualType "void", BaseType "c")+ , (UnQualType "float", BaseType "f")+ , (UnQualType "double", BaseType "d")+ ]++-- | Clone of python's struct.calcsize.+calcsize :: String -> Int+calcsize str = sum [fromMaybe 1 i * getSize c | (i, c) <- parseMembers str]+ where+ sizeM :: M.Map Char Int+ sizeM = M.fromList [ ('c', 1)+ , ('B', 1)+ , ('b', 1)+ , ('H', 2)+ , ('h', 2)+ , ('I', 4)+ , ('i', 4)+ , ('Q', 8)+ , ('q', 8)+ , ('f', 4)+ , ('d', 8)+ , ('x', 1)+ ]+ getSize = (M.!) sizeM++ parseMembers :: String -> [(Maybe Int, Char)]+ parseMembers s = case parseOnly lang (BS.pack s) of+ Left err -> error ("can't calcsize " ++ s ++ " " ++ err)+ Right xs -> xs++ lang = many $ (,) <$> optional decimal <*> (satisfy $ inClass $ M.keys sizeM)++xBinopToPyOp :: X.Binop -> P.Op ()+xBinopToPyOp X.Add = P.Plus ()+xBinopToPyOp X.Sub = P.Minus ()+xBinopToPyOp X.Mult = P.Multiply ()+xBinopToPyOp X.Div = P.FloorDivide ()+xBinopToPyOp X.And = P.BinaryAnd ()+xBinopToPyOp X.RShift = P.ShiftRight ()++xUnopToPyOp :: X.Unop -> P.Op ()+xUnopToPyOp X.Complement = P.Invert ()++xExpressionToNestedPyExpr :: (String -> String) -> XExpression -> Expr ()+xExpressionToNestedPyExpr acc (Op o e1 e2) =+ Paren (xExpressionToPyExpr acc (Op o e1 e2)) ()+xExpressionToNestedPyExpr acc xexpr =+ xExpressionToPyExpr acc xexpr++xExpressionToPyExpr :: (String -> String) -> XExpression -> Expr ()+xExpressionToPyExpr _ (Value i) = mkInt i+xExpressionToPyExpr _ (Bit i) = BinaryOp (ShiftLeft ()) (mkInt 1) (mkInt i) ()+xExpressionToPyExpr acc (FieldRef n) = mkName $ acc n+xExpressionToPyExpr _ (EnumRef _ n) = mkName n+xExpressionToPyExpr acc (PopCount e) =+ mkCall "xcffib.popcount" [xExpressionToPyExpr acc e]+-- http://cgit.freedesktop.org/xcb/proto/tree/doc/xml-xcb.txt#n290+xExpressionToPyExpr acc (SumOf n) = mkCall "sum" [mkName $ acc n]+xExpressionToPyExpr acc (Op o e1 e2) =+ let o' = xBinopToPyOp o+ e1' = xExpressionToNestedPyExpr acc e1+ e2' = xExpressionToNestedPyExpr acc e2+ in BinaryOp o' e1' e2' ()+xExpressionToPyExpr acc (Unop o e) =+ let o' = xUnopToPyOp o+ e' = xExpressionToNestedPyExpr acc e+ in Paren (UnaryOp o' e' ()) ()++getConst :: XExpression -> Maybe Int+getConst (Value i) = Just i+getConst (Bit i) = Just $ bit i+getConst (Op o e1 e2) = do+ c1 <- getConst e1+ c2 <- getConst e2+ return $ case o of+ X.Add -> c1 + c2+ X.Sub -> c1 - c2+ X.Mult -> c1 * c2+ X.Div -> c1 `quot` c2+ X.And -> c1 .&. c2+ X.RShift -> c1 `shift` c2+getConst (Unop o e) = do+ c <- getConst e+ return $ case o of+ X.Complement -> complement c+getConst (PopCount e) = fmap popCount $ getConst e+getConst _ = Nothing++xEnumElemsToPyEnum :: (String -> String) -> [XEnumElem] -> [(String, Expr ())]+xEnumElemsToPyEnum accessor membs = reverse $ conv membs [] [1..]+ where+ exprConv = xExpressionToPyExpr accessor+ conv :: [XEnumElem] -> [(String, Expr ())] -> [Int] -> [(String, Expr ())]+ conv ((EnumElem name expr) : els) acc is =+ let expr' = fromMaybe (mkInt (head is)) $ fmap exprConv expr+ is' = tail is+ acc' = (name, expr') : acc+ in conv els acc' is'+ conv [] acc _ = acc++-- Add the xcb_generic_{request,reply}_t structure data to the beginning of a+-- pack string. This is a little weird because both structs contain a one byte+-- pad which isn't at the end. If the first element of the request or reply is+-- a byte long, it takes that spot instead, and there is one less offset+addStructData :: String -> String -> String+addStructData prefix (c : cs) | c `elem` "Bbx" =+ let result = maybePrintChar prefix c+ in if result == prefix then result ++ (c : cs) else result ++ cs+addStructData prefix s = (maybePrintChar prefix 'x') ++ s++maybePrintChar :: String -> Char -> String+maybePrintChar s c | "%c" `isInfixOf` s = printf s c+maybePrintChar s _ = s++-- Don't prefix a single pad byte with a '1'. This is simpler to parse+-- visually, and also simplifies addStructData above.+mkPad :: Int -> String+mkPad 1 = "x"+mkPad i = (show i) ++ "x"++structElemToPyUnpack :: Expr ()+ -> String+ -> TypeInfoMap+ -> GenStructElem Type+ -> Either (Maybe String, String)+ (String, Expr (), Expr (), Maybe Int)+structElemToPyUnpack _ _ _ (Pad i) = Left (Nothing, mkPad i)++-- XXX: This is a cheap hack for noop, we should really do better.+structElemToPyUnpack _ _ _ (Doc _ _ _) = Left (Nothing, "")+-- XXX: What does fd/switch mean? we should implement it correctly+structElemToPyUnpack _ _ _ (Fd _) = Left (Nothing, "")+structElemToPyUnpack _ _ _ (Switch _ _ _) = Left (Nothing, "")++-- The enum field is mostly for user information, so we ignore it.+structElemToPyUnpack unpacker ext m (X.List n typ len _) =+ let attr = ((++) "self.")+ len' = fromMaybe pyNone $ fmap (xExpressionToPyExpr attr) len+ cons = case m M.! typ of+ BaseType c -> mkStr c+ CompositeType tExt c | ext /= tExt -> mkName $ tExt ++ "." ++ c+ CompositeType _ c -> mkName c+ list = mkCall "xcffib.List" [ unpacker+ , cons+ , len'+ ]+ constLen = do+ l <- len+ getConst l+ in Right (n, list, cons, constLen)++-- The mask and enum fields are for user information, we can ignore them here.+structElemToPyUnpack unpacker ext m (SField n typ _ _) =+ case m M.! typ of+ BaseType c -> Left (Just n, c)+ CompositeType tExt c ->+ let c' = if tExt == ext then c else tExt ++ "." ++ c+ field = mkCall c' [unpacker]+ -- TODO: Ugh. Nothing here is wrong. Do we really need to carry the+ -- length of these things around?+ in Right (n, field, mkName c', Nothing)+structElemToPyUnpack _ _ _ (ExprField _ _ _) = error "Only valid for requests"+structElemToPyUnpack _ _ _ (ValueParam _ _ _ _) = error "Only valid for requests"++structElemToPyPack :: String+ -> TypeInfoMap+ -> (String -> String)+ -> GenStructElem Type+ -> Either (Maybe String, String) [(String, Expr ())]+structElemToPyPack _ _ _ (Pad i) = Left (Nothing, mkPad i)+-- TODO: implement doc, switch, and fd?+structElemToPyPack _ _ _ (Doc _ _ _) = Left (Nothing, "")+structElemToPyPack _ _ _ (Switch _ _ _) = Left (Nothing, "")+structElemToPyPack _ _ _ (Fd _) = Left (Nothing, "")+structElemToPyPack _ m accessor (SField n typ _ _) =+ let name = accessor n+ in case m M.! typ of+ BaseType c -> Left (Just name, c)+ -- XXX: be a little smarter here? we should really make sure that things+ -- have a .pack(); if users are calling us via the old style api, we need+ -- to support that as well. This isn't super necessary, though, because+ -- currently (xcb-proto 1.10) there are no direct packs of raw structs, so+ -- this is really only necessary if xpyb gets forward ported in the future if+ -- there are actually calls of this type.+ CompositeType _ _ -> Right $ [(name, mkCall (name ++ ".pack") noArgs)]+-- TODO: assert values are in enum?+structElemToPyPack ext m accessor (X.List n typ _ _) =+ let name = accessor n+ in case m M.! typ of+ BaseType c -> Right $ [(name, mkCall "xcffib.pack_list" [ mkName $ name+ , mkStr c+ ])]+ CompositeType tExt c ->+ let c' = if tExt == ext then c else (tExt ++ "." ++ c)+ in Right $ [(name, mkCall "xcffib.pack_list" ([ mkName $ name+ , mkName c'+ ]))]+structElemToPyPack _ m accessor (ExprField name typ expr) =+ let e = (xExpressionToPyExpr accessor) expr+ name' = accessor name+ in case m M.! typ of+ BaseType c -> Right $ [(name', mkCall "struct.pack" [ mkStr ('=' : c)+ , e+ ])]+ CompositeType _ _ -> Right $ [(name',+ mkCall (mkDot e (mkName "pack")) noArgs)]++-- As near as I can tell here the padding param is unused.+structElemToPyPack _ m accessor (ValueParam typ mask _ list) =+ case m M.! typ of+ BaseType c ->+ let mask' = mkCall "struct.pack" [mkStr ('=' : c), mkName $ accessor mask]+ list' = mkCall "xcffib.pack_list" [ mkName $ accessor list+ , mkStr "I"+ ]+ in Right $ [(mask, mask'), (list, list')]+ CompositeType _ _ -> error (+ "ValueParams other than CARD{16,32} not allowed.")+++mkPackStmts :: String+ -> String+ -> TypeInfoMap+ -> (String -> String)+ -> String+ -> [GenStructElem Type]+ -> ([String], Suite ())+mkPackStmts ext name m accessor prefix membs =+ let buf = [mkAssign "buf" (mkCall "six.BytesIO" noArgs)]+ packF = structElemToPyPack ext m accessor+ (toPack, stmts) = partitionEithers $ map packF membs+ listWrites = map (flip StmtExpr () . mkCall "buf.write" . (: [])) lists+ (args, keys) = let (as, ks) = unzip toPack in (catMaybes as, ks)++ -- In some cases (e.g. xproto.ConfigureWindow) there is padding after+ -- value_mask. The way the xml specification deals with this is by+ -- specifying value_mask in both the regular pack location as well as+ -- implying it implicitly. Thus, we want to make sure that if we've already+ -- been told to pack something explcitly, that we don't also pack it+ -- implicitly.+ (listNames, lists) = unzip $ filter (flip notElem args . fst) (concat stmts)+ listNames' = case (ext, name) of+ -- XXX: QueryTextExtents has a field named "odd_length" with a+ -- fieldref of "string_len", so we fix it up here to match.+ ("xproto", "QueryTextExtents") ->+ let replacer "odd_length" = "string_len"+ replacer s = s+ in map replacer listNames+ _ -> listNames+ packStr = addStructData prefix $ intercalate "" keys+ write = mkCall "buf.write" [mkCall "struct.pack"+ (mkStr ('=' : packStr) : (map mkName args))]+ writeStmt = if length packStr > 0 then [StmtExpr write ()] else []+ in (args ++ listNames', buf ++ writeStmt ++ listWrites)++mkPackMethod :: String+ -> String+ -> TypeInfoMap+ -> [GenStructElem Type]+ -> Statement ()+mkPackMethod ext name m structElems =+ let accessor = ((++) "self.")+ (_, packStmts) = mkPackStmts ext name m accessor "" structElems+ ret = [mkReturn $ mkCall "buf.getvalue" noArgs]+ in mkMethod "pack" (mkParams ["self"]) $ packStmts ++ ret++data StructUnpackState = StructUnpackState {+ -- | stNeedsPad is whether or not a type_pad() is needed. As near+ -- as I can tell the conditions are:+ -- 1. a list was unpacked+ -- 2. a struct was unpacked+ -- ListFontsWithInfoReply is an example of a struct which has lots of+ -- this type of thing.+ stNeedsPad :: Bool,++ -- The list of names the struct.pack accumulator has, and the+ stNames :: [String],++ -- The list of pack directives (potentially with a "%c" in it for+ -- the prefix byte).+ stPacks :: String+}++-- | Make a struct style (i.e. not union style) unpack.+mkStructStyleUnpack :: String+ -> String+ -> TypeInfoMap+ -> [GenStructElem Type]+ -> (Suite (), Maybe Int)+mkStructStyleUnpack prefix ext m membs =+ let unpacked = map (structElemToPyUnpack (mkName "unpacker") ext m) membs+ initial = StructUnpackState False [] prefix+ (_, unpackStmts, size) = evalState (mkUnpackStmtsR unpacked) initial+ base = [mkAssign "base" $ mkName "unpacker.offset"]+ bufsize =+ let rhs = BinaryOp (Minus ()) (mkName "unpacker.offset") (mkName "base") ()+ in [mkAssign (mkAttr "bufsize") rhs]+ statements = base ++ unpackStmts ++ bufsize+ in (statements, size)++ where++ -- Apparently you only type_pad before unpacking Structs or Lists, never+ -- base types.+ mkUnpackStmtsR :: [Either (Maybe String, String)+ (String, Expr (), Expr (), Maybe Int)]+ -> State StructUnpackState ([String], Suite (), Maybe Int)++ mkUnpackStmtsR [] = flushAcc++ mkUnpackStmtsR (Left (name, pack) : xs) = do+ st <- get+ let packs = if "%c" `isInfixOf` (stPacks st)+ then addStructData (stPacks st) pack+ else (stPacks st) ++ pack+ put $ st { stNames = stNames st ++ maybeToList name+ , stPacks = packs+ }+ mkUnpackStmtsR xs++ mkUnpackStmtsR (Right (listName, list, cons, listSz) : xs) = do+ (packNames, packStmt, packSz) <- flushAcc+ st <- get+ put $ st { stNeedsPad = True }+ let pad = if stNeedsPad st+ then [typePad cons]+ else []+ (restNames, restStmts, restSz) <- mkUnpackStmtsR xs+ let totalSize = do+ before <- packSz+ rest <- restSz+ listSz' <- listSz+ return $ before + rest + listSz'+ listStmt = mkAssign (mkAttr listName) list+ return ( packNames ++ [listName] ++ restNames+ , packStmt ++ pad ++ listStmt : restStmts+ , totalSize+ )++ flushAcc :: State StructUnpackState ([String], Suite (), Maybe Int)+ flushAcc = do+ StructUnpackState needsPad args keys <- get+ let size = calcsize keys+ assign = mkUnpackFrom "unpacker" args keys+ put $ StructUnpackState needsPad [] ""+ return (args, assign, Just size)++ typePad e = StmtExpr (mkCall "unpacker.pad" [e]) ()++-- | Given a (qualified) type name and a target type, generate a TypeInfoMap+-- updater.+mkModify :: String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap+mkModify ext name ti m =+ let m' = M.fromList [ (UnQualType name, ti)+ , (QualType ext name, ti)+ ]+ in M.union m m'++processXDecl :: String+ -> XDecl+ -> State TypeInfoMap BindingPart+processXDecl ext (XTypeDef name typ) =+ do modify $ \m -> mkModify ext name (m M.! typ) m+ return Noop+processXDecl ext (XidType name) =+ -- http://www.markwitmer.com/guile-xcb/doc/guile-xcb/XIDs.html+ do modify $ mkModify ext name (BaseType "I")+ return Noop+processXDecl _ (XImport n) =+ return $ Declaration [ mkRelImport n]+processXDecl _ (XEnum name membs) =+ return $ Declaration [mkEnum name $ xEnumElemsToPyEnum id membs]+processXDecl ext (XStruct n membs) = do+ m <- get+ let (statements, len) = mkStructStyleUnpack "" ext m membs+ pack = mkPackMethod ext n m membs+ fixedLength = maybeToList $ do+ theLen <- len+ let rhs = mkInt theLen+ return $ mkAssign "fixed_size" rhs+ modify $ mkModify ext n (CompositeType ext n)+ return $ Declaration [mkXClass n "xcffib.Struct" statements (pack : fixedLength)]+processXDecl ext (XEvent name opcode membs noSequence) = do+ m <- get+ let cname = name ++ "Event"+ pack = mkPackMethod ext name m membs+ prefix = if fromMaybe False noSequence then "x" else "x%c2x"+ (statements, _) = mkStructStyleUnpack prefix ext m membs+ eventsUpd = mkDictUpdate "_events" opcode cname+ return $ Declaration [ mkXClass cname "xcffib.Event" statements [pack]+ , eventsUpd+ ]+processXDecl ext (XError name opcode membs) = do+ m <- get+ let cname = name ++ "Error"+ pack = mkPackMethod ext name m membs+ (statements, _) = mkStructStyleUnpack "xx2x" ext m membs+ errorsUpd = mkDictUpdate "_errors" opcode cname+ alias = mkAssign ("Bad" ++ name) (mkName cname)+ return $ Declaration [ mkXClass cname "xcffib.Error" statements [pack]+ , alias+ , errorsUpd+ ]+processXDecl ext (XRequest name opcode membs reply) = do+ m <- get+ let (args, packStmts) = mkPackStmts ext name m id "x%c2x" membs+ cookieName = (name ++ "Cookie")+ replyDecl = concat $ maybeToList $ do+ reply' <- reply+ let (replyStmts, _) = mkStructStyleUnpack "x%c2x4x" ext m reply'+ replyName = name ++ "Reply"+ theReply = mkXClass replyName "xcffib.Reply" replyStmts []+ replyType = mkAssign "reply_type" $ mkName replyName+ cookie = mkClass cookieName "xcffib.Cookie" [replyType]+ return [theReply, cookie]++ hasReply = if length replyDecl > 0+ then [ArgExpr (mkName cookieName) ()]+ else []+ isChecked = pyTruth $ isJust reply+ argChecked = ArgKeyword (ident "is_checked") (mkName "is_checked") ()+ checkedParam = Param (ident "is_checked") Nothing (Just isChecked) ()+ allArgs = (mkParams $ "self" : args) ++ [checkedParam]+ mkArg = flip ArgExpr ()+ ret = mkReturn $ mkCall "self.send_request" ((map mkArg [ mkInt opcode+ , mkName "buf"+ ])+ ++ hasReply+ ++ [argChecked])+ requestBody = packStmts ++ [ret]+ request = mkMethod name allArgs requestBody+ return $ Request request replyDecl+processXDecl ext (XUnion name membs) = do+ m <- get+ let unpackF = structElemToPyUnpack unpackerCopy ext m+ (fields, listInfo) = partitionEithers $ map unpackF membs+ toUnpack = concat $ map mkUnionUnpack fields+ (names, exprs, _, _) = unzip4 listInfo+ lists = map (uncurry mkAssign) $ zip (map mkAttr names) exprs+ initMethod = lists ++ toUnpack+ decl = [mkXClass name "xcffib.Union" initMethod []]+ modify $ mkModify ext name (CompositeType ext name)+ return $ Declaration decl+ where+ unpackerCopy = mkCall "unpacker.copy" noArgs+ mkUnionUnpack :: (Maybe String, String)+ -> Suite ()+ mkUnionUnpack (n, typ) =+ mkUnpackFrom unpackerCopy (maybeToList n) typ++processXDecl ext (XidUnion name _) =+ -- These are always unions of only XIDs.+ do modify $ mkModify ext name (BaseType "I")+ return Noop++mkVersion :: XHeader -> Suite ()+mkVersion header =+ let major = ver "MAJOR_VERSION" (xheader_major_version header)+ minor = ver "MINOR_VERSION" (xheader_minor_version header)+ in major ++ minor+ where+ ver :: String -> Maybe Int -> Suite ()+ ver target i = maybeToList $ fmap (\x -> mkAssign target (mkInt x)) i++mkKey :: XHeader -> Maybe (Statement ())+mkKey header = do+ name <- xheader_xname header+ let call = mkCall "xcffib.ExtensionKey" [mkStr name]+ return $ mkAssign "key" call
+ generator/Data/XCB/Python/PyHelpers.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module Data.XCB.Python.PyHelpers (+ mkImport,+ mkRelImport,+ mkInt,+ mkAssign,+ mkCall,+ noArgs,+ mkEnum,+ mkName,+ mkDot,+ mkAttr,+ mkIncr,+ mkClass,+ mkEmptyClass,+ mkXClass,+ mkStr,+ mkUnpackFrom,+ mkDict,+ mkDictUpdate,+ mkMethod,+ mkReturn,+ pyTruth,+ mkParams,+ ident,+ pyNone+ ) where++import Data.List.Split+import Data.Maybe++import Language.Python.Common++_reserved :: [String]+_reserved = [ "None"+ , "def"+ , "class"+ , "and"+ , "or"+ ]++class PseudoExpr a where+ getExpr :: a -> Expr ()++instance PseudoExpr String where+ getExpr s = mkName s+instance PseudoExpr (Expr ()) where+ getExpr = id++-- | Create and sanatize a python identifier.+ident :: String -> Ident ()+ident s | s `elem` _reserved = Ident ("_" ++ s) ()+ident s | isInt s = Ident ("_" ++ s) ()+ where+ isInt str = isJust $ ((maybeRead str) :: Maybe Int)+ maybeRead = fmap fst . listToMaybe . reads+ident s = Ident s ()++-- Make a DottedName out of a string like "foo.bar" for use in imports.+mkDottedName :: String -> DottedName ()+mkDottedName = map ident . splitOn "."++mkVar :: String -> Expr ()+mkVar name = Var (ident name) ()++-- | Make an Expr out of a string like "foo.bar" describing the name.+mkName :: String -> Expr ()+mkName s =+ let strings = map mkVar $ reverse $ splitOn "." s+ in foldr mkDot (head strings) (reverse $ tail strings)++mkDot :: (PseudoExpr a, PseudoExpr b) => a -> b -> Expr ()+mkDot e1 e2 = BinaryOp (Dot ()) (getExpr e1) (getExpr e2) ()++-- | Make an attribute access, i.e. self.<string>.+mkAttr :: String -> Expr ()+mkAttr s = mkName ("self." ++ s)++mkImport :: String -> Statement ()+mkImport name = Import [ImportItem (mkDottedName name) Nothing ()] ()++mkRelImport :: String -> Statement ()+mkRelImport name = FromImport (ImportRelative 1 Nothing ()) (FromItems [FromItem (ident name) Nothing ()] ()) ()++mkInt :: Int -> Expr ()+mkInt i = Int (toInteger i) (show i) ()++mkAssign :: PseudoExpr a => a -> Expr () -> Statement ()+mkAssign name expr = Assign [getExpr name] expr ()++mkIncr :: String -> Expr () -> Statement ()+mkIncr name expr = AugmentedAssign (mkName name) (PlusAssign ()) expr ()++class PseudoArgument a where+ getArgument :: a -> Argument ()++instance PseudoArgument (Expr ()) where+ getArgument p = ArgExpr p ()+instance PseudoArgument (Argument ()) where+ getArgument = id++mkCall :: (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()+mkCall name args = Call (getExpr name) (map getArgument args) ()++noArgs :: [Argument ()]+noArgs = []++mkEnum :: String -> [(String, Expr ())] -> Statement ()+mkEnum cname values =+ let body = map (uncurry mkAssign) values+ in Class (Ident cname ()) [] body ()++mkParams :: [String] -> [Parameter ()]+mkParams = map (\x -> Param (ident x) Nothing Nothing ())++mkArg :: String -> Argument ()+mkArg n = ArgExpr (mkName n) ()++mkXClass :: String -> String -> Suite () -> Suite () -> Statement ()+mkXClass clazz superclazz [] [] = mkEmptyClass clazz superclazz+mkXClass clazz superclazz constructor methods =+ let args = [ "self", "unpacker" ]+ super = mkCall (superclazz ++ ".__init__") $ map mkName args+ body = [(StmtExpr super ())] ++ constructor+ initParams = mkParams args+ initMethod = Fun (ident "__init__") initParams Nothing body ()+ in mkClass clazz superclazz $ initMethod : methods++mkEmptyClass :: String -> String -> Statement ()+mkEmptyClass clazz superclazz = mkClass clazz superclazz [Pass ()]++mkClass :: String -> String -> Suite () -> Statement ()+mkClass clazz superclazz body = Class (ident clazz) [mkArg superclazz] body ()++mkStr :: String -> Expr ()+mkStr s = Strings ["\"", s, "\""] ()++mkTuple :: [Expr ()] -> Expr ()+mkTuple = flip Tuple ()++mkUnpackFrom :: PseudoExpr a => a -> [String] -> String -> Suite ()+mkUnpackFrom unpacker names packs =+ let lhs = mkTuple $ map mkAttr names+ -- Don't spam with this default arg unless it is really necessary.+ unpackF = mkDot unpacker "unpack"+ rhs = mkCall unpackF [mkStr packs]+ stmt = if length names > 0 then mkAssign lhs rhs else StmtExpr rhs ()+ in if length packs > 0 then [stmt] else []++mkDict :: String -> Statement ()+mkDict name = mkAssign name (Dictionary [] ())++mkDictUpdate :: String -> Int -> String -> Statement ()+mkDictUpdate dict key value =+ mkAssign (Subscript (mkName dict) (mkInt key) ()) (mkName value)++mkMethod :: String -> [Parameter ()] -> Suite () -> Statement ()+mkMethod name args body = Fun (ident name) args Nothing body ()++mkReturn :: Expr () -> Statement ()+mkReturn = flip Return () . Just++pyTruth :: Bool -> Expr ()+pyTruth = flip Bool ()++pyNone :: Expr ()+pyNone = None ()
+ generator/xcffibgen.hs view
@@ -0,0 +1,51 @@+module Main where++import Data.XCB.Types+import Data.XCB.Python.Parse++import Options.Applicative++import System.Directory+import System.FilePath++data Xcffibgen = Xcffibgen { input :: String+ , output :: String+ }++options :: Parser Xcffibgen+options = Xcffibgen+ <$> strOption+ ( long "input"+ <> metavar "DIR"+ <> help "Input directory containing xcb xml files.")+ <*> strOption+ ( long "output"+ <> metavar "DIR"+ <> help "Output directory for generated python.")++-- Headers we can't emit right now. Obviously we want to get rid of this :-)+badHeaders :: [String]+badHeaders = [ "xkb"+ , "xprint"+ ]++run :: Xcffibgen -> IO ()+run (Xcffibgen inp out) = do+ headers <- parseXHeaders inp+ let headers' = filter (flip notElem badHeaders . xheader_header) headers+ createDirectoryIfMissing True out+ sequence_ $ map processFile $ xform headers'+ where+ processFile (fname, suite) = do+ putStrLn fname+ let fname' = out </> fname ++ ".py"+ contents = renderPy suite+ writeFile fname' contents++main :: IO ()+main = execParser opts >>= run+ where+ opts = info (helper <*> options)+ ( fullDesc+ <> progDesc "Generate XCB bindings for python."+ <> header "xcffib - the cffi-based XCB generator")
+ tests/GeneratorTests.hs view
@@ -0,0 +1,55 @@+module Main (main) where++import Language.Python.Common++import Data.XCB.Python.Parse+import Data.XCB.FromXML+import Data.XCB.Types++import Test.Framework ( defaultMain, Test )+import Test.Framework.Providers.HUnit+import Test.HUnit hiding ( Test )++import System.FilePath++pyTests :: [String]+pyTests = [ "event"+ , "error"+ , "request"+ , "union"+ , "struct"+ , "enum"+ , "request_reply"+ , "no_sequence"+ , "type_pad"+ ]++mkFname :: String -> FilePath+mkFname = (</>) $ "tests" </> "generator"++mkTest :: String -> IO Test+mkTest name = do+ header <- fromFiles [mkFname $ name <.> ".xml"]+ rawExpected <- readFile . mkFname $ name <.> ".py"+ let [(fname, outPy)] = xform header+ rawOut = renderPy outPy+ return $ testCase name $ do assertEqual "names equal" name fname+ -- TODO: we should really parse and compare ASTs+ assertEqual "rendering equal" rawExpected rawOut+++calcsizeTests :: [Test]+calcsizeTests =+ let tests = [ ("x2xBx", 5)+ , ("24xHhII", 24 + 2 * 2 + 2 * 4)+ ]+ in map mkTest tests+ where+ mkTest (str, expected) =+ let result = calcsize str+ in testCase "calcsize" (assertEqual str expected result)++main :: IO ()+main = do+ genTests <- mapM mkTest pyTests+ defaultMain $ calcsizeTests ++ genTests
+ tests/PyHelpersTests.hs view
@@ -0,0 +1,34 @@+module Main (main) where++import Language.Python.Common++import Data.XCB.Python.PyHelpers++import Test.Framework ( defaultMain, Test )+import Test.Framework.Providers.HUnit+import Test.HUnit hiding ( Test )++mkTest :: (Show a, Eq a) => String -> a -> a -> Test+mkTest name t1 t2 = testCase name (assertEqual name t1 t2)++testMkName :: Test+testMkName =+ let result = mkName "self.foo.bar"+ expected = BinaryOp (Dot ())+ (Var (Ident "self" ()) ())+ (BinaryOp (Dot ())+ (Var (Ident "foo" ()) ())+ (Var (Ident "bar" ()) ())+ ())+ ()+ in mkTest "testMkName" expected result++testReserves :: Test+testReserves =+ let result = mkName "None"+ expected = (Var (Ident "_None" ()) ())+ in mkTest "testReserves" expected result++main :: IO ()+main = do+ defaultMain [testMkName, testReserves]
+ xcffib.cabal view
@@ -0,0 +1,75 @@+name: xcffib+version: 0.1.5+synopsis: A cffi-based python binding for X+homepage: http://github.com/tych0/xcffib+license: MIT+license-file: LICENSE+author: Tycho Andersen+maintainer: Tycho Andersen <tycho@tycho.ws>+category: X11+build-type: Simple+cabal-version: >=1.8+bug-reports: https://github.com/tych0/xcffib/issues+description: A cffi-based python binding for X, comparable to xpyb++source-repository head+ type: git+ location: git://github.com/tych0/xcffib.git++library+ build-depends: base ==4.*,+ xcb-types >= 0.7.1,+ language-python >= 0.4.0,+ filepath,+ filemanip,+ split,+ containers,+ mtl >= 2.1,+ attoparsec,+ bytestring+ hs-source-dirs: generator+ exposed-modules: Data.XCB.Python.Parse,+ Data.XCB.Python.PyHelpers+ ghc-options: -Wall++executable xcffibgen+ main-is: xcffibgen.hs+ hs-source-dirs: generator+ build-depends: base ==4.*,+ xcffib >= 0.1.0,+ language-python >= 0.4.0,+ split,+ xcb-types >= 0.7.1,+ optparse-applicative >= 0.5,+ filepath,+ filemanip,+ directory >= 1.2,+ containers,+ mtl >= 2.1,+ attoparsec,+ bytestring+ ghc-options: -Wall++test-suite PyHelpersTests+ hs-source-dirs: tests+ main-is: PyHelpersTests.hs+ type: exitcode-stdio-1.0+ build-depends: base ==4.*,+ xcffib >= 0.1.0,+ language-python >= 0.4.0,+ HUnit,+ test-framework,+ test-framework-hunit++test-suite GeneratorTests.hs+ hs-source-dirs: tests+ main-is: GeneratorTests.hs+ type: exitcode-stdio-1.0+ build-depends: base ==4.*,+ xcffib >= 0.1.0,+ xcb-types >= 0.7.1,+ language-python >= 0.4.0,+ HUnit,+ test-framework,+ test-framework-hunit,+ filepath