diff --git a/generator/Data/XCB/Python/AST.hs b/generator/Data/XCB/Python/AST.hs new file mode 100644 --- /dev/null +++ b/generator/Data/XCB/Python/AST.hs @@ -0,0 +1,236 @@ +{- + - Copyright 2024 Tycho Andersen + - + - This module exists as a small AST to replace language-python, which seems + - largely unmaintained at this point. This is not really intended to be a + - complete python grammer, mostly it is just enough to be what xcffib needs to + - generate its trees. + - + - It has no annotations as in language-python, because xcffib doesn't use them. + - + - The grammar not complete: it cannot express anything other than empty + - dictionaries, cannot express sets at all, cannot do async, etc. all because + - these features of the language are unused by xcffib. + - + - The grammar is not sound: it has one "op" class, representing both unary and + - binary operators. + - + - Use at your own risk :) + -} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +module Data.XCB.Python.AST ( + Expr(..), + Suite, + Statement(..), + Ident, + Op(..), + Pretty(..), + prettyText, + PseudoExpr(..) +) where + +import Prelude hiding ((<>)) + +import Data.Maybe + +import Text.PrettyPrint + +type Suite = [Statement] + +type Ident = String + +-- we don't use that many operations :) +data Op + = Plus + | Minus + | Multiply + | FloorDivide + | BinaryAnd + | ShiftRight + | ShiftLeft + | Invert + | Equality + | LessThan + | Modulo + deriving (Eq, Ord, Show) + +data Statement + = Import + { import_item :: Ident } + -- this is only a one level dotted import; other levels are not supported + | FromImport + { from_module :: Ident + , from_item :: Ident + } + -- we skip While, For, AsyncFor, etc. because we don't use them + | Fun + { fun_name :: Ident + -- only named variables, no default values, kwargs, etc. + , fun_args :: [Ident] + , fun_body :: Suite + } + | Decorated + { decorations :: Ident + -- only decorated functions/methods are supported + , fun_name :: Ident + , fun_args :: [Ident] + , fun_body :: Suite + } + -- skip AsyncFun... + | Class + { class_name :: Ident + -- same as functions, only identifiers allowed + , class_args :: [Ident] + , class_body :: Suite + } + | Conditional + { if_cond :: Expr + , if_body :: Suite + , else_body :: Suite + } + | Assign + { assign_to :: Expr + , assign_expr :: Expr + } + | AugmentedAssign + { aug_assign_to :: Expr + , aug_assign_op :: Op + , aug_assign_expr :: Expr + } + -- skip AnnotatedAssign, Decorated + | Return + { return_expr :: Maybe (Expr) } + -- skip Try, With, AsyncWith + | Pass {} + -- skip Break, Continue, Delete + | StmtExpr + { stmt_expr :: Expr } + -- skip Global, NonLocal, Assert, Print, Exec + | Raise { raise_exception :: Ident } + deriving (Eq, Ord, Show) + +data Expr + = Var { var :: Ident } + | Int { int_value :: Int } + | Bool { bool_value :: Bool } + | None + | Strings { strings_strings :: [String] } + | Call + { call_fun :: Expr + , call_args :: [Expr] + } + | CondExpr + { ce_true_branch :: Expr + , ce_conditon :: Expr + , ce_false_branch :: Expr + } + | Subscript + { subscriptee :: Expr + , subscript_expr :: Expr + } + | BinaryOp + { operator :: Op + , binop_left :: Expr + , binop_right :: Expr + } + | UnaryOp + { operator :: Op + , unop_arg :: Expr + } + | Dot + { dot_expr :: Expr + , dot_attribute :: Ident + } + | Tuple { tuple_exprs :: [Expr] } + | EmptyDict {} -- an empty dictionary + | Paren { paren_expr :: Expr } + deriving (Eq, Ord, Show) + +prettyText :: Pretty a => a -> String +prettyText = render . pretty + +class Pretty a where + pretty :: a -> Doc + +instance Pretty Op where + pretty Plus = text "+" + pretty Minus = text "-" + pretty Multiply = text "*" + pretty FloorDivide = text "//" + pretty BinaryAnd = text "&" + pretty ShiftRight = text ">>" + pretty ShiftLeft = text "<<" + pretty Invert = text "~" + pretty Equality = text "==" + pretty LessThan = text "<" + pretty Modulo = text "%" + +_reserved :: [String] +_reserved = [ "None" + , "def" + , "class" + , "and" + , "or" + ] + +-- | Sanitize identifiers. +instance Pretty Ident where + pretty s | s `elem` _reserved = text $ "_" ++ s + pretty s | isInt s = text $ "_" ++ s + where + isInt str = isJust $ ((maybeRead str) :: Maybe Int) + maybeRead = fmap fst . listToMaybe . reads + pretty s = text s + +instance Pretty Suite where + pretty stmts = vcat $ map pretty stmts + +indent :: Doc -> Doc +indent = nest 4 + +instance Pretty Statement where + pretty (Import item) = text "import" <+> pretty item + pretty (FromImport source item) = text "from" <+> text source <+> text "import" <+> pretty item + pretty (Fun name args bod) = text "def" <+> pretty name <> (parens (addCommas args)) <> colon + $+$ indent (pretty bod) + pretty (Decorated decorator name args bod) = text "@" <> text decorator $+$ pretty (Fun name args bod) + pretty (Class name [] body) = text "class" <+> pretty name <> colon $+$ indent (pretty body) + pretty (Class name superclasses body) = text "class" <+> pretty name <> parens (addCommas superclasses) <> colon $+$ indent (pretty body) + pretty (Conditional cond if_ else_) = text "if" <+> pretty cond <> colon $+$ indent (pretty if_) $+$ pretty else_ + pretty (Assign to expr) = pretty to <+> text "=" <+> pretty expr + pretty (AugmentedAssign to op expr) = pretty to <+> pretty op <> text "=" <+> pretty expr + pretty (Return (Just expr)) = text "return" <+> pretty expr + pretty (Return Nothing) = text "return" + pretty Pass = text "pass" + pretty (StmtExpr expr) = pretty expr + pretty (Raise exc) = text "raise" <+> pretty exc + +class PseudoExpr a where + getExpr :: a -> Expr + +instance PseudoExpr String where + getExpr s = Var s +instance PseudoExpr Expr where + getExpr = id + +addCommas :: PseudoExpr a => [a] -> Doc +addCommas exprs = hsep $ punctuate (text ",") (map (pretty . getExpr) exprs) + +instance Pretty Expr where + pretty (Var v) = pretty v + pretty (Int i) = integer (toInteger i) + pretty (Bool True) = text "True" + pretty (Bool False) = text "False" + pretty None = text "None" + pretty (Strings xs) = hcat (map text xs) + pretty (Call fun args) = pretty fun <> lparen <> addCommas args <> rparen + pretty (CondExpr trueB cond falseB) = pretty trueB <+> text "if" <+> pretty cond <+> text "else" <+> pretty falseB + pretty (Subscript thing expr) = pretty thing <> brackets (pretty expr) + pretty (BinaryOp op left right) = pretty left <+> pretty op <+> pretty right + pretty (UnaryOp op arg) = pretty op <> pretty arg + pretty (Dot thing attr) = pretty thing <> text "." <> pretty attr + pretty (Tuple [expr]) = pretty expr <> comma -- one element still needs to be a tuple + pretty (Tuple exprs) = addCommas exprs + pretty EmptyDict = text "{}" + pretty (Paren expr) = lparen <> pretty expr <> rparen diff --git a/generator/Data/XCB/Python/Parse.hs b/generator/Data/XCB/Python/Parse.hs --- a/generator/Data/XCB/Python/Parse.hs +++ b/generator/Data/XCB/Python/Parse.hs @@ -34,10 +34,9 @@ import Data.Maybe import Data.XCB.FromXML import Data.XCB.Types as X +import Data.XCB.Python.AST (Expr(..), Op(..), Statement(..), Suite, prettyText) import Data.XCB.Python.PyHelpers -import Language.Python.Common as P - import System.FilePath import System.FilePath.Glob @@ -55,15 +54,15 @@ type TypeInfoMap = M.Map X.Type TypeInfo data BindingPart = - Request (Statement ()) (Suite ()) | - Declaration (Suite ()) | + Request Statement Suite | + Declaration Suite | Noop deriving (Show) -collectBindings :: [BindingPart] -> (Suite (), Suite ()) +collectBindings :: [BindingPart] -> (Suite, Suite) collectBindings = foldr collectR ([], []) where - collectR :: BindingPart -> (Suite (), Suite ()) -> (Suite (), Suite ()) + 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 @@ -73,25 +72,25 @@ files <- namesMatching $ fp "*.xml" fromFiles files -renderPy :: Suite () -> String +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 :: [XHeader] -> [(String, Suite)] xform = map buildPython . dependencyOrder where - buildPython :: Tree XHeader -> (String, Suite ()) + 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 ()) + -> State TypeInfoMap (String, Suite) processXHeader header = do - let imports = [mkImport "xcffib", mkImport "struct", mkImport "io"] + let imports = [Import "xcffib", Import "struct", Import "io"] version = mkVersion header key = maybeToList $ mkKey header globals = [mkDict "_events", mkDict "_errors"] @@ -120,20 +119,20 @@ postOrder (Node e cs) = (concat $ map postOrder cs) ++ [e] -mkAddExt :: XHeader -> Statement () +mkAddExt :: XHeader -> Statement mkAddExt (xheader_header -> "xproto") = - flip StmtExpr () $ mkCall "xcffib._add_core" [ mkName "xprotoExtension" - , mkName "Setup" - , mkName "_events" - , mkName "_errors" - ] + 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" - ] + in StmtExpr $ mkCall "xcffib._add_ext" [ mkName "key" + , mkName (name ++ "Extension") + , mkName "_events" + , mkName "_errors" + ] -- | Information on basic X types. baseTypeInfo :: TypeInfoMap @@ -189,26 +188,26 @@ 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 () +xBinopToPyOp :: X.Binop -> Op +xBinopToPyOp X.Add = Plus +xBinopToPyOp X.Sub = Minus +xBinopToPyOp X.Mult = Multiply +xBinopToPyOp X.Div = FloorDivide +xBinopToPyOp X.And = BinaryAnd +xBinopToPyOp X.RShift = ShiftRight -xUnopToPyOp :: X.Unop -> P.Op () -xUnopToPyOp X.Complement = P.Invert () +xUnopToPyOp :: X.Unop -> Op +xUnopToPyOp X.Complement = Invert -xExpressionToNestedPyExpr :: (String -> String) -> XExpression -> Expr () +xExpressionToNestedPyExpr :: (String -> String) -> XExpression -> Expr xExpressionToNestedPyExpr acc (Op o e1 e2) = - Paren (xExpressionToPyExpr 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 :: (String -> String) -> XExpression -> Expr +xExpressionToPyExpr _ (Value i) = Int i +xExpressionToPyExpr _ (Bit i) = BinaryOp ShiftLeft (Int 1) (Int i) xExpressionToPyExpr acc (FieldRef n) = mkName $ acc n xExpressionToPyExpr _ (EnumRef (UnQualType enum) n) = mkName $ enum ++ "." ++ n -- Currently xcb only uses unqualified types, not sure how qualtype should behave @@ -221,11 +220,11 @@ let o' = xBinopToPyOp o e1' = xExpressionToNestedPyExpr acc e1 e2' = xExpressionToNestedPyExpr acc e2 - in BinaryOp o' e1' e2' () + in BinaryOp o' e1' e2' xExpressionToPyExpr acc (Unop o e) = let o' = xUnopToPyOp o e' = xExpressionToNestedPyExpr acc e - in Paren (UnaryOp o' e' ()) () + in Paren (UnaryOp o' e') xExpressionToPyExpr acc (ParamRef n) = if n == "num_axes" then mkName $ acc n @@ -251,13 +250,13 @@ getConst (PopCount e) = fmap popCount $ getConst e getConst _ = Nothing -xEnumElemsToPyEnum :: (String -> String) -> [XEnumElem] -> [(String, Expr ())] +xEnumElemsToPyEnum :: (String -> String) -> [XEnumElem] -> [(String, Expr)] xEnumElemsToPyEnum accessor membs = reverse $ conv membs [] [0..] where exprConv = xExpressionToPyExpr accessor - conv :: [XEnumElem] -> [(String, Expr ())] -> [Int] -> [(String, Expr ())] + conv :: [XEnumElem] -> [(String, Expr)] -> [Int] -> [(String, Expr)] conv ((EnumElem name expr) : els) acc is = - let expr' = fromMaybe (mkInt (head is)) $ fmap exprConv expr + let expr' = fromMaybe (Int (head is)) $ fmap exprConv expr is' = dropWhile (<= (fromIntegral (int_value expr'))) is acc' = (name, expr') : acc in conv els acc' is' @@ -283,13 +282,13 @@ mkPad 1 = "x" mkPad i = (show i) ++ "x" -structElemToPyUnpack :: Expr () +structElemToPyUnpack :: Expr -> String -> TypeInfoMap -> GenStructElem Type -> Either (Maybe String, String) - (String, Either (Expr (), Expr ()) - ([(Expr (), [GenStructElem Type])]), Maybe Int) + (String, Either (Expr, Expr) + ([(Expr, [GenStructElem Type])]), Maybe Int) structElemToPyUnpack _ _ _ (Pad PadBytes i) = Left (Nothing, mkPad i) structElemToPyUnpack _ _ _ (Pad PadAlignment _) = Left (Nothing, "") @@ -305,23 +304,27 @@ switch = map (mkSwitch cmp) bitcases in Right (name, Right switch, Nothing) where - mkSwitch :: Expr () + mkSwitch :: Expr -> BitCase - -> (Expr (), [GenStructElem Type]) + -> (Expr, [GenStructElem Type]) mkSwitch cmp (BitCase Nothing bcCmp _ elems) = - let cmpVal = xExpressionToPyExpr id bcCmp - equality = BinaryOp (P.BinaryAnd ()) cmp cmpVal () + -- note: head here and below is a hack; i am not exactly sure the + -- semantics of the multi-expression BitCase, since it's "fake" and + -- "encoded only once" see b3b5e029e7ad ("XKB: Fix GetKbdByName") for + -- details. needs some wiresniffing to investigate. + let cmpVal = xExpressionToPyExpr id (head bcCmp) + equality = BinaryOp BinaryAnd cmp cmpVal in (equality, elems) mkSwitch cmp (BitCase (Just _) bcCmp _ elems) = - let cmpVal = xExpressionToPyExpr id bcCmp - equality = BinaryOp (P.Equality ()) cmp cmpVal () + let cmpVal = xExpressionToPyExpr id (head bcCmp) + equality = BinaryOp Equality cmp cmpVal in (equality, elems) -- 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 + len' = fromMaybe None $ fmap (xExpressionToPyExpr attr) len cons = case m M.! typ of BaseType c -> mkStr c CompositeType tExt c | ext /= tExt -> mkName $ tExt ++ "." ++ c @@ -355,8 +358,8 @@ -> TypeInfoMap -> (String -> String) -> GenStructElem Type - -> Either (Maybe String, String) [(String, Either (Maybe (Expr ())) - [(Expr (), [GenStructElem Type])] + -> Either (Maybe String, String) [(String, Either (Maybe (Expr)) + [(Expr, [GenStructElem Type])] )] structElemToPyPack _ _ _ (Pad _ i) = Left (Nothing, mkPad i) -- TODO: implement these? @@ -369,25 +372,26 @@ elems = map (mkSwitch cmp) bitcases in Right $ [(name, Right elems)] where - mkSwitch :: Expr () + mkSwitch :: Expr -> BitCase - -> (Expr (), [GenStructElem Type]) + -> (Expr, [GenStructElem Type]) mkSwitch cmp (BitCase _ bcCmp _ elems') = - let cmpVal = xExpressionToPyExpr accessor bcCmp - equality = BinaryOp (P.BinaryAnd ()) cmp cmpVal () + -- see comment above about head for BitCase + let cmpVal = xExpressionToPyExpr accessor (head bcCmp) + equality = BinaryOp BinaryAnd cmp cmpVal in (equality, elems') structElemToPyPack ext m accessor (SField n typ _ _) = let name = accessor n in case m M.! typ of BaseType c -> Left (Just name, c) CompositeType tExt typNam -> - let cond = mkCall "hasattr" [mkArg name, ArgExpr (mkStr "pack") ()] - trueB = mkCall (name ++ ".pack") noArgs + let cond = mkCall "hasattr" [mkName name, (mkStr "pack")] + trueB = mkCall (name ++ ".pack") [] typNam' = if ext == tExt then typNam else tExt ++ "." ++ typNam - synthetic = mkCall (typNam' ++ ".synthetic") [mkArg ("*" ++ name)] - falseB = mkCall (mkDot synthetic "pack") noArgs + synthetic = mkCall (typNam' ++ ".synthetic") [mkName ("*" ++ name)] + falseB = mkCall (mkDot synthetic "pack") [] in Right $ [(name - , Left (Just (CondExpr trueB cond falseB ())) + , Left (Just (CondExpr trueB cond falseB)) )] -- TODO: assert values are in enum? structElemToPyPack ext m accessor (X.List n typ expr _) = @@ -421,7 +425,7 @@ ])) )] CompositeType _ _ -> Right $ [(name' - , Left (Just (mkCall (mkDot e "pack") noArgs)) + , Left (Just (mkCall (mkDot e "pack") [])) )] -- As near as I can tell here the padding param is unused. @@ -436,8 +440,8 @@ CompositeType _ _ -> error ( "ValueParams other than CARD{16,32} not allowed.") -buf :: Suite () -buf = [mkAssign "buf" (mkCall "io.BytesIO" noArgs)] +buf :: Suite +buf = [mkAssign "buf" (mkCall "io.BytesIO" [])] mkPackStmts :: String -> String @@ -445,7 +449,7 @@ -> (String -> String) -> String -> [GenStructElem Type] - -> ([String], Suite ()) + -> ([String], Suite) mkPackStmts ext name m accessor prefix membs = let packF = structElemToPyPack ext m accessor (toPack, stmts) = span EC.isLeft $ map packF membs @@ -471,30 +475,30 @@ 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 [] + writeStmt = if length packStr > 0 then [StmtExpr write] else [] in (args ++ listNames', writeStmt ++ listWrites) where mkWrites :: String - -> Either (Maybe (Expr ())) - [(Expr (), [GenStructElem Type])] - -> Suite () + -> Either (Maybe (Expr)) + [(Expr, [GenStructElem Type])] + -> Suite mkWrites _ (Left Nothing) = [] mkWrites _ (Left (Just expr)) = [mkListWrite expr] mkWrites valueList (Right condList) = let (conds, exprs) = unzip condList (names, stmts) = unzip $ map (mkPackStmts ext name m accessor "") exprs - in map (\(x, y, z) -> Conditional [(x, map (mkPop valueList) y ++ z)] [] ()) $ zip3 conds names stmts + in map (\(x, y, z) -> Conditional x (map (mkPop valueList) y ++ z) []) $ zip3 conds names stmts - mkListWrite :: Expr () - -> Statement () - mkListWrite expr' = flip StmtExpr () . mkCall "buf.write" $ (: []) expr' + mkListWrite :: Expr + -> Statement + mkListWrite expr' = StmtExpr . mkCall "buf.write" $ (: []) expr' mkPop :: String -> String - -> Statement () + -> Statement mkPop toPop n = - let pop = mkCall (mkDot toPop "pop") [mkInt 0] - in if null n then StmtExpr pop () else mkAssign n pop + let pop = mkCall (mkDot toPop "pop") [Int 0] + in if null n then StmtExpr pop else mkAssign n pop mkBasePack (Nothing, "") = [] mkBasePack (n, c) = @@ -507,28 +511,29 @@ -> Maybe (String, Int) -> [GenStructElem Type] -> Maybe Int - -> Statement () + -> Statement mkPackMethod ext name m prefixAndOp structElems minLen = let accessor = ((++) "self.") (prefix, op) = case prefixAndOp of Just ('x' : rest, i) -> - let packOpcode = mkCall "struct.pack" [mkStr "=B", mkInt i] + let packOpcode = mkCall "struct.pack" [mkStr "=B", Int i] write = mkCall "buf.write" [packOpcode] - in (rest, [StmtExpr write ()]) + in (rest, [StmtExpr write]) Just (rest, _) -> error ("internal API error: " ++ show rest) Nothing -> ("", []) (_, packStmts) = mkPackStmts ext name m accessor prefix structElems extend = concat $ do len <- maybeToList minLen let bufLen = mkName "buf_len" - bufLenAssign = mkAssign bufLen $ mkCall "len" [mkCall "buf.getvalue" noArgs] - test = (BinaryOp (LessThan ()) bufLen (mkInt len)) () - bufWriteLen = Paren (BinaryOp (Minus ()) (mkInt 32) bufLen ()) () - extra = mkCall "struct.pack" [repeatStr "x" bufWriteLen] - writeExtra = [StmtExpr (mkCall "buf.write" [extra]) ()] + bufLenAssign = mkAssign bufLen $ mkCall "len" [mkCall "buf.getvalue" []] + test = (BinaryOp LessThan bufLen (Int len)) + bufWriteLen = Paren (BinaryOp Minus (Int 32) bufLen) + extraPackFmt = Paren (BinaryOp Modulo (mkStr "%dx") bufWriteLen) + extra = mkCall "struct.pack" [extraPackFmt] + writeExtra = [StmtExpr (mkCall "buf.write" [extra])] return $ [bufLenAssign, mkIf test writeExtra] - ret = [mkReturn $ mkCall "buf.getvalue" noArgs] - in mkMethod "pack" (mkParams ["self"]) $ buf ++ op ++ packStmts ++ extend ++ ret + ret = [mkReturn $ mkCall "buf.getvalue" []] + in mkMethod "pack" ["self"] $ buf ++ op ++ packStmts ++ extend ++ ret data StructUnpackState = StructUnpackState { -- | stNeedsPad is whether or not a type_pad() is needed. As near @@ -552,14 +557,14 @@ -> String -> TypeInfoMap -> [GenStructElem Type] - -> (Suite (), Maybe Int) + -> (Suite, Maybe Int) mkStructStyleUnpack prefix ext m membs = let unpacked = map (structElemToPyUnpack (mkName "unpacker") ext m) membs initial = StructUnpackState False [] prefix (_, unpackStmts, size) = evalState (mkUnpackStmts unpacked) initial base = [mkAssign "base" $ mkName "unpacker.offset"] bufsize = - let rhs = BinaryOp (Minus ()) (mkName "unpacker.offset") (mkName "base") () + let rhs = BinaryOp Minus (mkName "unpacker.offset") (mkName "base") in [mkAssign (mkAttr "bufsize") rhs] statements = base ++ unpackStmts ++ bufsize in (statements, size) @@ -568,9 +573,9 @@ -- Apparently you only type_pad before unpacking Structs or Lists, never -- base types. mkUnpackStmts :: [Either (Maybe String, String) - (String, Either (Expr (), Expr ()) - ([(Expr (), [GenStructElem Type])]), Maybe Int)] - -> State StructUnpackState ([String], Suite (), Maybe Int) + (String, Either (Expr, Expr) + ([(Expr, [GenStructElem Type])]), Maybe Int)] + -> State StructUnpackState ([String], Suite, Maybe Int) mkUnpackStmts [] = flushAcc @@ -601,11 +606,11 @@ ) where mkUnpackListOrSwitch :: String - -> Either (Expr (), Expr ()) - ([(Expr (), [GenStructElem Type])]) + -> Either (Expr, Expr) + ([(Expr, [GenStructElem Type])]) -> Bool -> StructUnpackState - -> Suite () + -> Suite mkUnpackListOrSwitch name' (Left (list, cons)) needsPad _ = let pad = if needsPad then [typePad cons] @@ -614,17 +619,17 @@ mkUnpackListOrSwitch _ (Right switchList) _ st' = let (conds, elems) = unzip switchList stmts = map (mkUnpackSwitchElems st') elems - in map (\x -> Conditional [x] [] ()) $ zip conds stmts + in map (\(cond,body) -> Conditional cond body []) $ zip conds stmts mkUnpackSwitchElems :: StructUnpackState -> [GenStructElem Type] - -> Suite () + -> Suite mkUnpackSwitchElems st' elems' = let unpacked' = map (structElemToPyUnpack (mkName "unpacker") ext m) elems' (_, stmts', _) = evalState (mkUnpackStmts unpacked') st' in stmts' - flushAcc :: State StructUnpackState ([String], Suite (), Maybe Int) + flushAcc :: State StructUnpackState ([String], Suite, Maybe Int) flushAcc = do StructUnpackState needsPad args keys <- get let size = calcsize keys @@ -632,7 +637,7 @@ put $ StructUnpackState needsPad [] "" return (args, assign, Just size) - typePad e = StmtExpr (mkCall "unpacker.pad" [e]) () + typePad e = StmtExpr (mkCall "unpacker.pad" [e]) -- | Given a (qualified) type name and a target type, generate a TypeInfoMap -- updater. @@ -643,16 +648,15 @@ ] in M.union m m' -mkSyntheticMethod :: [GenStructElem Type] -> [Statement ()] +mkSyntheticMethod :: [GenStructElem Type] -> [Statement] mkSyntheticMethod membs = do let names = catMaybes $ map getName membs - args = mkParams $ "cls" : names + args = "cls" : names self = mkAssign "self" $ mkCall (mkDot "cls" "__new__") [mkName "cls"] body = map assign names ret = mkReturn $ mkName "self" - synthetic = mkMethod "synthetic" args $ (self : body) ++ [ret] - classmethod = Decorator [ident "classmethod"] noArgs () - if null names then [] else [Decorated [classmethod] synthetic ()] + synthetic = Decorated "classmethod" "synthetic" args $ (self : body) ++ [ret] + if null names then [] else [synthetic] where getName :: GenStructElem Type -> Maybe String getName (Pad _ _) = Nothing @@ -665,7 +669,7 @@ getName (Fd n) = Just n getName (Length _ _) = Nothing - assign :: String -> Statement () + assign :: String -> Statement assign n = mkAssign (mkDot "self" n) $ mkName n processXDecl :: String @@ -689,7 +693,7 @@ synthetic = mkSyntheticMethod membs fixedLength = maybeToList $ do theLen <- len - let rhs = mkInt theLen + let rhs = Int theLen return $ mkAssign "fixed_size" rhs modify $ mkModify ext n (CompositeType ext n) return $ Declaration [mkXClass n "xcffib.Struct" False statements (pack : fixedLength ++ synthetic)] @@ -736,18 +740,20 @@ return [theReply, cookie] hasReply = if length replyDecl > 0 - then [ArgExpr (mkName cookieName) ()] + then [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" : (filter (not . null) args)) ++ [checkedParam] - mkArg' = flip ArgExpr () - ret = mkReturn $ mkCall "self.send_request" ((map mkArg' [ mkInt opcode - , mkName "buf" - ]) - ++ hasReply - ++ [argChecked]) + -- another hack for not supporting named parameters + -- argChecked = ArgKeyword (ident "is_checked") (mkName "is_checked") + argChecked = mkName ("is_checked=is_checked") + -- a hack to not have to support separate params/exprs + -- checkedParam = Param (ident "is_checked") Nothing (Just isChecked) + checkedParam = "is_checked=" ++ (show (isJust reply)) + allArgs = ("self" : (filter (not . null) args)) ++ [checkedParam] + ret = mkReturn $ mkCall "self.send_request" ([ Int opcode + , mkName "buf" + ] + ++ hasReply + ++ [argChecked]) requestBody = buf ++ packStmts ++ [ret] request = mkMethod name allArgs requestBody return $ Request request replyDecl @@ -756,11 +762,9 @@ let unpackF = structElemToPyUnpack unpackerCopy ext m (fields, listInfo) = span EC.isLeft $ map unpackF membs toUnpack = concat $ map (mkUnionUnpack . EC.fromLeft') fields - listInfo' = map (either mkBaseUnpack id) listInfo - (names, listOrSwitches, _) = unzip3 listInfo' - (exprs, _) = unzip $ map EC.fromLeft' listOrSwitches - lists = map (uncurry mkAssign) $ zip (map mkAttr names) exprs - initMethod = lists ++ toUnpack + initMethod = if any EC.isLeft listInfo + then [notImplemented] + else (mkListUnpack listInfo) ++ toUnpack -- Here, we only want to pack the first member of the union, since every -- member is the same data and we don't want to repeatedly pack it. pack = mkPackMethod ext name m Nothing [head membs] Nothing @@ -768,13 +772,18 @@ modify $ mkModify ext name (CompositeType ext name) return $ Declaration decl where - unpackerCopy = mkCall "unpacker.copy" noArgs + unpackerCopy = mkCall "unpacker.copy" [] mkUnionUnpack :: (Maybe String, String) - -> Suite () + -> Suite mkUnionUnpack (n, typ) = mkUnpackFrom unpackerCopy (maybeToList n) typ - mkBaseUnpack _ = error "xcffib: trailing base types unpack not implemented" + mkListUnpack listInfo = + let listInfo' = map EC.fromRight' listInfo + (names, listOrSwitches, _) = unzip3 listInfo' + (exprs, _) = unzip $ map EC.fromLeft' listOrSwitches + lists = map (uncurry mkAssign) $ zip (map mkAttr names) exprs + in lists processXDecl ext (XidUnion name _) = -- These are always unions of only XIDs. @@ -796,16 +805,16 @@ modify $ mkModify ext name (CompositeType ext name) return $ Declaration $ [mkXClass name "xcffib.Buffer" False [] []] -mkVersion :: XHeader -> Suite () +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 + ver :: String -> Maybe Int -> Suite + ver target i = maybeToList $ fmap (\x -> mkAssign target (Int x)) i -mkKey :: XHeader -> Maybe (Statement ()) +mkKey :: XHeader -> Maybe (Statement) mkKey header = do name <- xheader_xname header let call = mkCall "xcffib.ExtensionKey" [mkStr name] diff --git a/generator/Data/XCB/Python/PyHelpers.hs b/generator/Data/XCB/Python/PyHelpers.hs --- a/generator/Data/XCB/Python/PyHelpers.hs +++ b/generator/Data/XCB/Python/PyHelpers.hs @@ -15,13 +15,9 @@ -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Data.XCB.Python.PyHelpers ( - mkImport, mkRelImport, - mkInt, mkAssign, mkCall, - noArgs, - mkArg, mkEnum, mkName, mkDot, @@ -36,113 +32,52 @@ mkDictUpdate, mkMethod, mkReturn, - pyTruth, - mkParams, - ident, - pyNone, mkIf, - repeatStr + notImplemented ) 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) () +import Data.XCB.Python.AST (Expr(..), Op(..), Statement(..), Suite, Ident, PseudoExpr, getExpr) -- | Make an Expr out of a string like "foo.bar" describing the name. -mkName :: String -> Expr () +mkName :: String -> Expr mkName s = let strings = splitOn "." s - in foldl mkDot (mkVar $ head strings) (tail strings) + in foldl mkDot (Var $ head strings) (tail strings) -mkDot :: PseudoExpr a => a -> String -> Expr () -mkDot e1 attr = Dot (getExpr e1) (ident attr) () +mkDot :: PseudoExpr a => a -> String -> Expr +mkDot e1 attr = Dot (getExpr e1) attr -- | Make an attribute access, i.e. self.. -mkAttr :: String -> Expr () +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 () +mkRelImport :: String -> Statement +mkRelImport name = FromImport "." name -instance PseudoArgument (Expr ()) where - getArgument p = ArgExpr p () -instance PseudoArgument (Argument ()) where - getArgument = id +mkAssign :: PseudoExpr a => a -> Expr -> Statement +mkAssign name expr = Assign (getExpr name) expr -mkCall :: (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr () -mkCall name args = Call (getExpr name) (map getArgument args) () +mkIncr :: String -> Expr -> Statement +mkIncr name expr = AugmentedAssign (mkName name) Plus expr -noArgs :: [Argument ()] -noArgs = [] +mkCall :: PseudoExpr a => a -> [Expr] -> Expr +mkCall name args = Call (getExpr name) args -mkEnum :: String -> [(String, Expr ())] -> Statement () +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) () + in Class cname [] body -mkXClass :: String -> String -> Bool -> Suite () -> Suite () -> Statement () +mkXClass :: String -> String -> Bool -> Suite -> Suite -> Statement mkXClass clazz superclazz False [] [] = mkEmptyClass clazz superclazz mkXClass clazz superclazz xge constructor methods = let args = [ "self", "unpacker" ] super = mkCall (superclazz ++ ".__init__") $ map mkName args - body = eventToUnpacker : (StmtExpr super ()) : constructor - initParams = mkParams args + body = eventToUnpacker : (StmtExpr super) : constructor xgeexp = mkAssign "xge" (if xge then (mkName "True") else (mkName "False")) - initMethod = Fun (ident "__init__") initParams Nothing body () + initMethod = Fun "__init__" args body in mkClass clazz superclazz $ xgeexp : initMethod : methods where @@ -151,55 +86,46 @@ -- passed directly to __init__. Since we don't keep track of the -- underlying buffers after the event is created, we have to re-pack -- things so they can be unpacked again. - eventToUnpacker :: Statement () + eventToUnpacker :: Statement eventToUnpacker = let newUnpacker = mkAssign "unpacker" (mkCall "xcffib.MemoryUnpacker" - [mkCall "unpacker.pack" noArgs]) + [mkCall "unpacker.pack" []]) cond = mkCall "isinstance" [mkName "unpacker", mkName "xcffib.Protobj"] in mkIf cond [newUnpacker] -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 () +mkEmptyClass :: String -> String -> Statement +mkEmptyClass clazz superclazz = mkClass clazz superclazz [Pass] -mkStr :: String -> Expr () -mkStr s = Strings ["\"", s, "\""] () +mkClass :: String -> String -> Suite -> Statement +mkClass clazz superclazz body = Class clazz [superclazz] body -mkTuple :: [Expr ()] -> Expr () -mkTuple = flip Tuple () +mkStr :: String -> Expr +mkStr s = Strings ["\"", s, "\""] -mkUnpackFrom :: PseudoExpr a => a -> [String] -> String -> Suite () +mkUnpackFrom :: PseudoExpr a => a -> [String] -> String -> Suite mkUnpackFrom unpacker names packs = - let lhs = mkTuple $ map mkAttr names + let lhs = Tuple $ 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 () + 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 [] ()) +mkDict :: String -> Statement +mkDict name = mkAssign name EmptyDict -mkDictUpdate :: String -> Int -> String -> Statement () +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 + mkAssign (Subscript (mkName dict) (Int key)) (mkName value) -pyTruth :: Bool -> Expr () -pyTruth = flip Bool () +mkMethod :: String -> [Ident] -> Suite -> Statement +mkMethod name args body = Fun name args body -pyNone :: Expr () -pyNone = None () +mkReturn :: Expr -> Statement +mkReturn = Return . Just -mkIf :: Expr () -> Suite () -> Statement () -mkIf e s = Conditional [(e, s)] [] () +mkIf :: Expr -> Suite -> Statement +mkIf e s = Conditional e s [] -repeatStr :: String -> Expr () -> Expr () -repeatStr s i = BinaryOp (Multiply ()) (mkStr s) i () +notImplemented :: Statement +notImplemented = Raise "xcffib.XcffibNotImplemented" diff --git a/generator/xcffibgen.hs b/generator/xcffibgen.hs --- a/generator/xcffibgen.hs +++ b/generator/xcffibgen.hs @@ -15,8 +15,6 @@ -} module Main where - -import Data.XCB.Types import Data.XCB.Python.Parse import Options.Applicative @@ -39,18 +37,11 @@ <> 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' + sequence_ $ map processFile $ xform headers where processFile (fname, suite) = do putStrLn fname diff --git a/test/GeneratorTests.hs b/test/GeneratorTests.hs --- a/test/GeneratorTests.hs +++ b/test/GeneratorTests.hs @@ -15,8 +15,7 @@ -} module Main (main) where -import Language.Python.Common - +import Data.XCB.Python.AST import Data.XCB.Python.Parse import Data.XCB.FromXML import Data.XCB.Types diff --git a/test/PyHelpersTests.hs b/test/PyHelpersTests.hs --- a/test/PyHelpersTests.hs +++ b/test/PyHelpersTests.hs @@ -15,9 +15,8 @@ -} module Main (main) where -import Language.Python.Common - import Data.XCB.Python.PyHelpers +import Data.XCB.Python.AST import Test.Framework ( defaultMain, Test ) import Test.Framework.Providers.HUnit @@ -29,15 +28,15 @@ testMkName :: Test testMkName = let result = mkName "self.foo.bar" - expected = (Dot (Dot (Var (Ident "self" ()) ()) - (Ident "foo" ()) ()) - (Ident "bar" ()) ()) + expected = (Dot (Dot (Var "self") + "foo") + "bar") in mkTest "testMkName" expected result testReserves :: Test testReserves = - let result = mkName "None" - expected = (Var (Ident "_None" ()) ()) + let result = prettyText (mkName "None") + expected = "_None" in mkTest "testReserves" expected result main :: IO () diff --git a/test/generator/event.py b/test/generator/event.py --- a/test/generator/event.py +++ b/test/generator/event.py @@ -21,7 +21,7 @@ buf.write(struct.pack("=B2xIIIIHHHHHH", self.rotation, self.timestamp, self.config_timestamp, self.root, self.request_window, self.sizeID, self.subpixel_order, self.width, self.height, self.mwidth, self.mheight)) buf_len = len(buf.getvalue()) if buf_len < 32: - buf.write(struct.pack("x" * (32 - buf_len))) + buf.write(struct.pack(("%dx" % (32 - buf_len)))) return buf.getvalue() @classmethod def synthetic(cls, rotation, timestamp, config_timestamp, root, request_window, sizeID, subpixel_order, width, height, mwidth, mheight): diff --git a/test/generator/no_sequence.py b/test/generator/no_sequence.py --- a/test/generator/no_sequence.py +++ b/test/generator/no_sequence.py @@ -19,7 +19,7 @@ buf.write(xcffib.pack_list(self.keys, "B")) buf_len = len(buf.getvalue()) if buf_len < 32: - buf.write(struct.pack("x" * (32 - buf_len))) + buf.write(struct.pack(("%dx" % (32 - buf_len)))) return buf.getvalue() @classmethod def synthetic(cls, keys): diff --git a/test/generator/record.py b/test/generator/record.py new file mode 100644 --- /dev/null +++ b/test/generator/record.py @@ -0,0 +1,118 @@ +import xcffib +import struct +import io +MAJOR_VERSION = 1 +MINOR_VERSION = 13 +key = xcffib.ExtensionKey("RECORD") +_events = {} +_errors = {} +class Range8(xcffib.Struct): + xge = False + def __init__(self, unpacker): + if isinstance(unpacker, xcffib.Protobj): + unpacker = xcffib.MemoryUnpacker(unpacker.pack()) + xcffib.Struct.__init__(self, unpacker) + base = unpacker.offset + self.first, self.last = unpacker.unpack("BB") + self.bufsize = unpacker.offset - base + def pack(self): + buf = io.BytesIO() + buf.write(struct.pack("=BB", self.first, self.last)) + return buf.getvalue() + fixed_size = 2 + @classmethod + def synthetic(cls, first, last): + self = cls.__new__(cls) + self.first = first + self.last = last + return self +class Range16(xcffib.Struct): + xge = False + def __init__(self, unpacker): + if isinstance(unpacker, xcffib.Protobj): + unpacker = xcffib.MemoryUnpacker(unpacker.pack()) + xcffib.Struct.__init__(self, unpacker) + base = unpacker.offset + self.first, self.last = unpacker.unpack("HH") + self.bufsize = unpacker.offset - base + def pack(self): + buf = io.BytesIO() + buf.write(struct.pack("=HH", self.first, self.last)) + return buf.getvalue() + fixed_size = 4 + @classmethod + def synthetic(cls, first, last): + self = cls.__new__(cls) + self.first = first + self.last = last + return self +class ExtRange(xcffib.Struct): + xge = False + def __init__(self, unpacker): + if isinstance(unpacker, xcffib.Protobj): + unpacker = xcffib.MemoryUnpacker(unpacker.pack()) + xcffib.Struct.__init__(self, unpacker) + base = unpacker.offset + self.major = Range8(unpacker) + unpacker.pad(Range16) + self.minor = Range16(unpacker) + self.bufsize = unpacker.offset - base + def pack(self): + buf = io.BytesIO() + buf.write(self.major.pack() if hasattr(self.major, "pack") else Range8.synthetic(*self.major).pack()) + buf.write(self.minor.pack() if hasattr(self.minor, "pack") else Range16.synthetic(*self.minor).pack()) + return buf.getvalue() + @classmethod + def synthetic(cls, major, minor): + self = cls.__new__(cls) + self.major = major + self.minor = minor + return self +class Range(xcffib.Struct): + xge = False + def __init__(self, unpacker): + if isinstance(unpacker, xcffib.Protobj): + unpacker = xcffib.MemoryUnpacker(unpacker.pack()) + xcffib.Struct.__init__(self, unpacker) + base = unpacker.offset + self.core_requests = Range8(unpacker) + unpacker.pad(Range8) + self.core_replies = Range8(unpacker) + unpacker.pad(ExtRange) + self.ext_requests = ExtRange(unpacker) + unpacker.pad(ExtRange) + self.ext_replies = ExtRange(unpacker) + unpacker.pad(Range8) + self.delivered_events = Range8(unpacker) + unpacker.pad(Range8) + self.device_events = Range8(unpacker) + unpacker.pad(Range8) + self.errors = Range8(unpacker) + self.client_started, self.client_died = unpacker.unpack("BB") + self.bufsize = unpacker.offset - base + def pack(self): + buf = io.BytesIO() + buf.write(self.core_requests.pack() if hasattr(self.core_requests, "pack") else Range8.synthetic(*self.core_requests).pack()) + buf.write(self.core_replies.pack() if hasattr(self.core_replies, "pack") else Range8.synthetic(*self.core_replies).pack()) + buf.write(self.ext_requests.pack() if hasattr(self.ext_requests, "pack") else ExtRange.synthetic(*self.ext_requests).pack()) + buf.write(self.ext_replies.pack() if hasattr(self.ext_replies, "pack") else ExtRange.synthetic(*self.ext_replies).pack()) + buf.write(self.delivered_events.pack() if hasattr(self.delivered_events, "pack") else Range8.synthetic(*self.delivered_events).pack()) + buf.write(self.device_events.pack() if hasattr(self.device_events, "pack") else Range8.synthetic(*self.device_events).pack()) + buf.write(self.errors.pack() if hasattr(self.errors, "pack") else Range8.synthetic(*self.errors).pack()) + buf.write(struct.pack("=B", self.client_started)) + buf.write(struct.pack("=B", self.client_died)) + return buf.getvalue() + @classmethod + def synthetic(cls, core_requests, core_replies, ext_requests, ext_replies, delivered_events, device_events, errors, client_started, client_died): + self = cls.__new__(cls) + self.core_requests = core_requests + self.core_replies = core_replies + self.ext_requests = ext_requests + self.ext_replies = ext_replies + self.delivered_events = delivered_events + self.device_events = device_events + self.errors = errors + self.client_started = client_started + self.client_died = client_died + return self +xcffib._add_ext(key, recordExtension, _events, _errors) diff --git a/test/generator/record.xml b/test/generator/record.xml new file mode 100644 --- /dev/null +++ b/test/generator/record.xml @@ -0,0 +1,33 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/xcffib.cabal b/xcffib.cabal --- a/xcffib.cabal +++ b/xcffib.cabal @@ -1,14 +1,14 @@ +cabal-version: 2.4 name: xcffib -version: 1.5.0 +version: 1.6.0 synopsis: A cffi-based python binding for X homepage: http://github.com/tych0/xcffib -license: OtherLicense +license: Apache-2.0 license-file: LICENSE author: Tycho Andersen maintainer: Tycho Andersen category: X11 build-type: Simple -cabal-version: >=1.10 bug-reports: https://github.com/tych0/xcffib/issues description: A cffi-based python binding for X, comparable to xpyb extra-source-files: test/generator/*.py, @@ -25,19 +25,20 @@ library build-depends: base ==4.*, - xcb-types >= 0.13.0, - language-python >= 0.5.6, - filepath, - filemanip, - split, - containers, - mtl >= 2.1, - attoparsec, - bytestring, - either + xcb-types >= 0.15.0 && < 0.16, + filepath >= 1.4.2 && < 1.5, + filemanip >= 0.3.6 && < 0.4, + split >= 0.2.3 && < 0.3, + containers >= 0.6.5 && < 0.7, + mtl >= 2.2.2 && < 2.4, + attoparsec >= 0.14.4 && < 0.15, + bytestring >= 0.11.3 && < 0.12, + either >= 5.0.2 && < 5.1, + pretty >= 1.1 && < 1.2 hs-source-dirs: generator exposed-modules: Data.XCB.Python.Parse, Data.XCB.Python.PyHelpers + Data.XCB.Python.AST ghc-options: -Wall default-language: Haskell2010 @@ -46,22 +47,21 @@ hs-source-dirs: generator build-depends: base ==4.*, xcffib, - language-python >= 0.5.6, - split, - xcb-types >= 0.13.0, - optparse-applicative >= 0.13, - filepath, - filemanip, - directory >= 1.2, - containers, - mtl >= 2.1, - attoparsec, - bytestring, - either - if impl(ghc < 8.0) - build-depends: semigroups + xcb-types >= 0.15.0 && < 0.16, + filepath >= 1.4.2 && < 1.5, + filemanip >= 0.3.6 && < 0.4, + split >= 0.2.3 && < 0.3, + containers >= 0.6.5 && < 0.7, + mtl >= 2.2.2 && < 2.4, + attoparsec >= 0.14.4 && < 0.15, + bytestring >= 0.11.3 && < 0.12, + either >= 5.0.2 && < 5.1, + pretty >= 1.1 && < 1.2, + directory >= 1.3.6 && < 1.4, + optparse-applicative >= 0.18.1 && < 0.19 other-modules: Data.XCB.Python.Parse, Data.XCB.Python.PyHelpers + Data.XCB.Python.AST ghc-options: -Wall default-language: Haskell2010 @@ -71,10 +71,9 @@ type: exitcode-stdio-1.0 build-depends: base ==4.*, xcffib, - language-python >= 0.5.6, - HUnit, - test-framework, - test-framework-hunit + HUnit >= 1.6.2 && < 1.7, + test-framework >= 0.8.2 && < 0.9, + test-framework-hunit >= 0.3.0 && < 0.4 default-language: Haskell2010 test-suite GeneratorTests.hs @@ -83,10 +82,9 @@ type: exitcode-stdio-1.0 build-depends: base ==4.*, xcffib, - xcb-types >= 0.13.0, - language-python >= 0.5.6, - HUnit, - test-framework, - test-framework-hunit, - filepath + xcb-types >= 0.15.0 && < 0.16, + filepath >= 1.4.2 && < 1.5, + HUnit >= 1.6.2 && < 1.7, + test-framework >= 0.8.2 && < 0.9, + test-framework-hunit >= 0.3.0 && < 0.4 default-language: Haskell2010