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 =
BaseType String |
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"
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])
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"
]
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")
]
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]
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 [] [0..]
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' = dropWhile (<= (fromIntegral (int_value expr'))) is
acc' = (name, expr') : acc
in conv els acc' is'
conv [] acc _ = acc
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
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)
structElemToPyUnpack _ _ _ (Doc _ _ _) = Left (Nothing, "")
structElemToPyUnpack _ _ _ (Fd _) = Left (Nothing, "")
structElemToPyUnpack _ _ _ (Switch _ _ _) = Left (Nothing, "")
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)
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]
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)
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)
CompositeType _ _ -> Right $ [(name, mkCall (name ++ ".pack") noArgs)]
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 "pack") noArgs)]
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.")
buf :: Suite ()
buf = [mkAssign "buf" (mkCall "six.BytesIO" noArgs)]
mkPackStmts :: String
-> String
-> TypeInfoMap
-> (String -> String)
-> String
-> [GenStructElem Type]
-> ([String], Suite ())
mkPackStmts ext name m accessor prefix membs =
let 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)
(listNames, lists) = unzip $ filter (flip notElem args . fst) (concat stmts)
listNames' = case (ext, name) of
("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', writeStmt ++ listWrites)
mkPackMethod :: String
-> String
-> TypeInfoMap
-> Maybe (String, Int)
-> [GenStructElem Type]
-> Maybe Int
-> 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]
write = mkCall "buf.write" [packOpcode]
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]) ()]
return $ [bufLenAssign, mkIf test writeExtra]
ret = [mkReturn $ mkCall "buf.getvalue" noArgs]
in mkMethod "pack" (mkParams ["self"]) $ buf ++ op ++ packStmts ++ extend ++ ret
data StructUnpackState = StructUnpackState {
stNeedsPad :: Bool,
stNames :: [String],
stPacks :: String
}
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
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]) ()
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) =
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 Nothing membs Nothing
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"
prefix = if fromMaybe False noSequence then "x" else "x%c2x"
pack = mkPackMethod ext name m (Just (prefix, opcode)) membs (Just 32)
(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"
prefix = "xx2x"
pack = mkPackMethod ext name m (Just (prefix, opcode)) membs Nothing
(statements, _) = mkStructStyleUnpack prefix 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
prefix = if ext == "xtest" then "xx2x" else "x%c2x"
(args, packStmts) = mkPackStmts ext name m id prefix 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 = buf ++ 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
pack = mkPackMethod ext name m Nothing [head membs] Nothing
decl = [mkXClass name "xcffib.Union" initMethod [pack]]
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 _) =
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