diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/generator/Data/XCB/Python/Parse.hs b/generator/Data/XCB/Python/Parse.hs new file mode 100644 --- /dev/null +++ b/generator/Data/XCB/Python/Parse.hs @@ -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 diff --git a/generator/Data/XCB/Python/PyHelpers.hs b/generator/Data/XCB/Python/PyHelpers.hs new file mode 100644 --- /dev/null +++ b/generator/Data/XCB/Python/PyHelpers.hs @@ -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.. +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 () diff --git a/generator/xcffibgen.hs b/generator/xcffibgen.hs new file mode 100644 --- /dev/null +++ b/generator/xcffibgen.hs @@ -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") diff --git a/tests/GeneratorTests.hs b/tests/GeneratorTests.hs new file mode 100644 --- /dev/null +++ b/tests/GeneratorTests.hs @@ -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 diff --git a/tests/PyHelpersTests.hs b/tests/PyHelpersTests.hs new file mode 100644 --- /dev/null +++ b/tests/PyHelpersTests.hs @@ -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] diff --git a/xcffib.cabal b/xcffib.cabal new file mode 100644 --- /dev/null +++ b/xcffib.cabal @@ -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 +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