{-
 - Copyright 2014 Tycho Andersen
 -
 - Licensed under the Apache License, Version 2.0 (the "License");
 - you may not use this file except in compliance with the License.
 - You may obtain a copy of the License at
 -
 -   http://www.apache.org/licenses/LICENSE-2.0
 -
 - Unless required by applicable law or agreed to in writing, software
 - distributed under the License is distributed on an "AS IS" BASIS,
 - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 - See the License for the specific language governing permissions and
 - limitations under the License.
 -}
{-# 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.Combinators as EC
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.AST (Expr(..), Op(..), Statement(..), Suite, prettyText)
import Data.XCB.Python.PyHelpers

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.
  CompositeType String String
  deriving (TypeInfo -> TypeInfo -> Bool
(TypeInfo -> TypeInfo -> Bool)
-> (TypeInfo -> TypeInfo -> Bool) -> Eq TypeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeInfo -> TypeInfo -> Bool
== :: TypeInfo -> TypeInfo -> Bool
$c/= :: TypeInfo -> TypeInfo -> Bool
/= :: TypeInfo -> TypeInfo -> Bool
Eq, Eq TypeInfo
Eq TypeInfo =>
(TypeInfo -> TypeInfo -> Ordering)
-> (TypeInfo -> TypeInfo -> Bool)
-> (TypeInfo -> TypeInfo -> Bool)
-> (TypeInfo -> TypeInfo -> Bool)
-> (TypeInfo -> TypeInfo -> Bool)
-> (TypeInfo -> TypeInfo -> TypeInfo)
-> (TypeInfo -> TypeInfo -> TypeInfo)
-> Ord TypeInfo
TypeInfo -> TypeInfo -> Bool
TypeInfo -> TypeInfo -> Ordering
TypeInfo -> TypeInfo -> TypeInfo
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TypeInfo -> TypeInfo -> Ordering
compare :: TypeInfo -> TypeInfo -> Ordering
$c< :: TypeInfo -> TypeInfo -> Bool
< :: TypeInfo -> TypeInfo -> Bool
$c<= :: TypeInfo -> TypeInfo -> Bool
<= :: TypeInfo -> TypeInfo -> Bool
$c> :: TypeInfo -> TypeInfo -> Bool
> :: TypeInfo -> TypeInfo -> Bool
$c>= :: TypeInfo -> TypeInfo -> Bool
>= :: TypeInfo -> TypeInfo -> Bool
$cmax :: TypeInfo -> TypeInfo -> TypeInfo
max :: TypeInfo -> TypeInfo -> TypeInfo
$cmin :: TypeInfo -> TypeInfo -> TypeInfo
min :: TypeInfo -> TypeInfo -> TypeInfo
Ord, Int -> TypeInfo -> ShowS
[TypeInfo] -> ShowS
TypeInfo -> String
(Int -> TypeInfo -> ShowS)
-> (TypeInfo -> String) -> ([TypeInfo] -> ShowS) -> Show TypeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeInfo -> ShowS
showsPrec :: Int -> TypeInfo -> ShowS
$cshow :: TypeInfo -> String
show :: TypeInfo -> String
$cshowList :: [TypeInfo] -> ShowS
showList :: [TypeInfo] -> ShowS
Show)

type TypeInfoMap = M.Map X.Type TypeInfo

data BindingPart =
  Request Statement Suite |
  Declaration Suite |
  Noop
  deriving (Int -> BindingPart -> ShowS
[BindingPart] -> ShowS
BindingPart -> String
(Int -> BindingPart -> ShowS)
-> (BindingPart -> String)
-> ([BindingPart] -> ShowS)
-> Show BindingPart
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BindingPart -> ShowS
showsPrec :: Int -> BindingPart -> ShowS
$cshow :: BindingPart -> String
show :: BindingPart -> String
$cshowList :: [BindingPart] -> ShowS
showList :: [BindingPart] -> ShowS
Show)

collectBindings :: [BindingPart] -> (Suite, Suite)
collectBindings :: [BindingPart] -> (Suite, Suite)
collectBindings = (BindingPart -> (Suite, Suite) -> (Suite, Suite))
-> (Suite, Suite) -> [BindingPart] -> (Suite, Suite)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BindingPart -> (Suite, Suite) -> (Suite, Suite)
collectR ([], [])
  where
    collectR :: BindingPart -> (Suite, Suite) -> (Suite, Suite)
    collectR :: BindingPart -> (Suite, Suite) -> (Suite, Suite)
collectR (Request Statement
def Suite
decl) (Suite
defs, Suite
decls) = (Statement
def Statement -> Suite -> Suite
forall a. a -> [a] -> [a]
: Suite
defs, Suite
decl Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
decls)
    collectR (Declaration Suite
decl) (Suite
defs, Suite
decls) = (Suite
defs, Suite
decl Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
decls)
    collectR BindingPart
Noop (Suite, Suite)
x = (Suite, Suite)
x

parseXHeaders :: FilePath -> IO [XHeader]
parseXHeaders :: String -> IO [XHeader]
parseXHeaders String
fp = do
  [String]
files <- String -> IO [String]
namesMatching (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String
fp String -> ShowS
</> String
"*.xml"
  [String] -> IO [XHeader]
fromFiles [String]
files

renderPy :: Suite -> String
renderPy :: Suite -> String
renderPy Suite
s = ((String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n") ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Statement -> String) -> Suite -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Statement -> String
forall a. Pretty a => a -> String
prettyText Suite
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\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 = (Tree XHeader -> (String, Suite))
-> [Tree XHeader] -> [(String, Suite)]
forall a b. (a -> b) -> [a] -> [b]
map Tree XHeader -> (String, Suite)
buildPython ([Tree XHeader] -> [(String, Suite)])
-> ([XHeader] -> [Tree XHeader]) -> [XHeader] -> [(String, Suite)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XHeader] -> [Tree XHeader]
dependencyOrder
  where
    buildPython :: Tree XHeader -> (String, Suite)
    buildPython :: Tree XHeader -> (String, Suite)
buildPython Tree XHeader
forest =
      let forest' :: StateT TypeInfoMap Identity [(String, Suite)]
forest' = ((XHeader -> StateT TypeInfoMap Identity (String, Suite))
-> [XHeader] -> StateT TypeInfoMap Identity [(String, Suite)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM XHeader -> StateT TypeInfoMap Identity (String, Suite)
processXHeader ([XHeader] -> StateT TypeInfoMap Identity [(String, Suite)])
-> [XHeader] -> StateT TypeInfoMap Identity [(String, Suite)]
forall a b. (a -> b) -> a -> b
$ Tree XHeader -> [XHeader]
forall a. Tree a -> [a]
postOrder Tree XHeader
forest)
          results :: [(String, Suite)]
results = StateT TypeInfoMap Identity [(String, Suite)]
-> TypeInfoMap -> [(String, Suite)]
forall s a. State s a -> s -> a
evalState StateT TypeInfoMap Identity [(String, Suite)]
forest' TypeInfoMap
baseTypeInfo
      in [(String, Suite)] -> (String, Suite)
forall a. HasCallStack => [a] -> a
last [(String, Suite)]
results
    processXHeader :: XHeader
                   -> State TypeInfoMap (String, Suite)
    processXHeader :: XHeader -> StateT TypeInfoMap Identity (String, Suite)
processXHeader XHeader
header = do
      let imports :: Suite
imports = [String -> Statement
Import String
"xcffib", String -> Statement
Import String
"struct", String -> Statement
Import String
"io"]
          version :: Suite
version = XHeader -> Suite
mkVersion XHeader
header
          key :: Suite
key = Maybe Statement -> Suite
forall a. Maybe a -> [a]
maybeToList (Maybe Statement -> Suite) -> Maybe Statement -> Suite
forall a b. (a -> b) -> a -> b
$ XHeader -> Maybe Statement
mkKey XHeader
header
          globals :: Suite
globals = [String -> Statement
mkDict String
"_events", String -> Statement
mkDict String
"_errors"]
          name :: String
name = XHeader -> String
forall typ. GenXHeader typ -> String
xheader_header XHeader
header
          add :: Suite
add = [XHeader -> Statement
mkAddExt XHeader
header]
      [BindingPart]
parts <- (XDecl -> StateT TypeInfoMap Identity BindingPart)
-> [XDecl] -> StateT TypeInfoMap Identity [BindingPart]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> XDecl -> StateT TypeInfoMap Identity BindingPart
processXDecl String
name) ([XDecl] -> StateT TypeInfoMap Identity [BindingPart])
-> [XDecl] -> StateT TypeInfoMap Identity [BindingPart]
forall a b. (a -> b) -> a -> b
$ XHeader -> [XDecl]
forall typ. GenXHeader typ -> [GenXDecl typ]
xheader_decls XHeader
header
      let (Suite
requests, Suite
decls) = [BindingPart] -> (Suite, Suite)
collectBindings [BindingPart]
parts
          ext :: Suite
ext = if Suite -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Suite
requests Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then [String -> String -> Suite -> Statement
mkClass (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Extension") String
"xcffib.Extension" Suite
requests]
                else []
      (String, Suite) -> StateT TypeInfoMap Identity (String, Suite)
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, Suite) -> StateT TypeInfoMap Identity (String, Suite))
-> (String, Suite) -> StateT TypeInfoMap Identity (String, Suite)
forall a b. (a -> b) -> a -> b
$ (String
name, [Suite] -> Suite
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Suite
imports, Suite
version, Suite
key, Suite
globals, Suite
decls, Suite
ext, Suite
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 :: [XHeader] -> [Tree XHeader]
dependencyOrder [XHeader]
headers = (String -> (XHeader, [String])) -> [String] -> [Tree XHeader]
forall b a. (b -> (a, [b])) -> [b] -> [Tree a]
unfoldForest String -> (XHeader, [String])
unfold ([String] -> [Tree XHeader]) -> [String] -> [Tree XHeader]
forall a b. (a -> b) -> a -> b
$ (XHeader -> String) -> [XHeader] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map XHeader -> String
forall typ. GenXHeader typ -> String
xheader_header [XHeader]
headers
      where
        headerM :: Map String XHeader
headerM = [(String, XHeader)] -> Map String XHeader
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, XHeader)] -> Map String XHeader)
-> [(String, XHeader)] -> Map String XHeader
forall a b. (a -> b) -> a -> b
$ (XHeader -> (String, XHeader)) -> [XHeader] -> [(String, XHeader)]
forall a b. (a -> b) -> [a] -> [b]
map (\XHeader
h -> (XHeader -> String
forall typ. GenXHeader typ -> String
xheader_header XHeader
h, XHeader
h)) [XHeader]
headers
        unfold :: String -> (XHeader, [String])
unfold String
s = let h :: XHeader
h = Map String XHeader
headerM Map String XHeader -> String -> XHeader
forall k a. Ord k => Map k a -> k -> a
M.! String
s in (XHeader
h, XHeader -> [String]
deps XHeader
h)
        deps :: XHeader -> [String]
        deps :: XHeader -> [String]
deps = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String])
-> (XHeader -> [Maybe String]) -> XHeader -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XDecl -> Maybe String) -> [XDecl] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map XDecl -> Maybe String
matchImport ([XDecl] -> [Maybe String])
-> (XHeader -> [XDecl]) -> XHeader -> [Maybe String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XHeader -> [XDecl]
forall typ. GenXHeader typ -> [GenXDecl typ]
xheader_decls
        matchImport :: XDecl -> Maybe String
        matchImport :: XDecl -> Maybe String
matchImport (XImport String
n) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
        matchImport XDecl
_ = Maybe String
forall a. Maybe a
Nothing
    postOrder :: Tree a -> [a]
    postOrder :: forall a. Tree a -> [a]
postOrder (Node a
e [Tree a]
cs) = ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ (Tree a -> [a]) -> [Tree a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Tree a -> [a]
forall a. Tree a -> [a]
postOrder [Tree a]
cs) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
e]


mkAddExt :: XHeader -> Statement
mkAddExt :: XHeader -> Statement
mkAddExt (XHeader -> String
forall typ. GenXHeader typ -> String
xheader_header -> String
"xproto") =
  Expr -> Statement
StmtExpr (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"xcffib._add_core" [ String -> Expr
mkName String
"xprotoExtension"
                                       , String -> Expr
mkName String
"Setup"
                                       , String -> Expr
mkName String
"_events"
                                       , String -> Expr
mkName String
"_errors"
                                       ]
mkAddExt XHeader
header =
  let name :: String
name = XHeader -> String
forall typ. GenXHeader typ -> String
xheader_header XHeader
header
  in Expr -> Statement
StmtExpr (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"xcffib._add_ext" [ String -> Expr
mkName String
"key"
                                         , String -> Expr
mkName (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Extension")
                                         , String -> Expr
mkName String
"_events"
                                         , String -> Expr
mkName String
"_errors"
                                         ]

-- | Information on basic X types.
baseTypeInfo :: TypeInfoMap
baseTypeInfo :: TypeInfoMap
baseTypeInfo = [(Type, TypeInfo)] -> TypeInfoMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Type, TypeInfo)] -> TypeInfoMap)
-> [(Type, TypeInfo)] -> TypeInfoMap
forall a b. (a -> b) -> a -> b
$
  [ (String -> Type
UnQualType String
"CARD8",    String -> TypeInfo
BaseType String
"B")
  , (String -> Type
UnQualType String
"uint8_t",  String -> TypeInfo
BaseType String
"B")
  , (String -> Type
UnQualType String
"CARD16",   String -> TypeInfo
BaseType String
"H")
  , (String -> Type
UnQualType String
"uint16_t", String -> TypeInfo
BaseType String
"H")
  , (String -> Type
UnQualType String
"CARD32",   String -> TypeInfo
BaseType String
"I")
  , (String -> Type
UnQualType String
"uint32_t", String -> TypeInfo
BaseType String
"I")
  , (String -> Type
UnQualType String
"CARD64",   String -> TypeInfo
BaseType String
"Q")
  , (String -> Type
UnQualType String
"uint64_t", String -> TypeInfo
BaseType String
"Q")
  , (String -> Type
UnQualType String
"INT8",     String -> TypeInfo
BaseType String
"b")
  , (String -> Type
UnQualType String
"int8_t",   String -> TypeInfo
BaseType String
"b")
  , (String -> Type
UnQualType String
"INT16",    String -> TypeInfo
BaseType String
"h")
  , (String -> Type
UnQualType String
"int16_t",  String -> TypeInfo
BaseType String
"h")
  , (String -> Type
UnQualType String
"INT32",    String -> TypeInfo
BaseType String
"i")
  , (String -> Type
UnQualType String
"int32_t",  String -> TypeInfo
BaseType String
"i")
  , (String -> Type
UnQualType String
"INT64",    String -> TypeInfo
BaseType String
"q")
  , (String -> Type
UnQualType String
"uint64_t", String -> TypeInfo
BaseType String
"q")
  , (String -> Type
UnQualType String
"BYTE",     String -> TypeInfo
BaseType String
"B")
  , (String -> Type
UnQualType String
"BOOL",     String -> TypeInfo
BaseType String
"B")
  , (String -> Type
UnQualType String
"char",     String -> TypeInfo
BaseType String
"c")
  , (String -> Type
UnQualType String
"void",     String -> TypeInfo
BaseType String
"c")
  , (String -> Type
UnQualType String
"float",    String -> TypeInfo
BaseType String
"f")
  , (String -> Type
UnQualType String
"double",   String -> TypeInfo
BaseType String
"d")
  ]

-- | Clone of python's struct.calcsize.
calcsize :: String -> Int
calcsize :: String -> Int
calcsize String
str = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Char -> Int
getSize Char
c | (Maybe Int
i, Char
c) <- String -> [(Maybe Int, Char)]
parseMembers String
str]
  where
    sizeM :: M.Map Char Int
    sizeM :: Map Char Int
sizeM = [(Char, Int)] -> Map Char Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Char
'c', Int
1)
                       , (Char
'B', Int
1)
                       , (Char
'b', Int
1)
                       , (Char
'H', Int
2)
                       , (Char
'h', Int
2)
                       , (Char
'I', Int
4)
                       , (Char
'i', Int
4)
                       , (Char
'Q', Int
8)
                       , (Char
'q', Int
8)
                       , (Char
'f', Int
4)
                       , (Char
'd', Int
8)
                       , (Char
'x', Int
1)
                       ]
    getSize :: Char -> Int
getSize = Map Char Int -> Char -> Int
forall k a. Ord k => Map k a -> k -> a
(M.!) Map Char Int
sizeM

    parseMembers :: String -> [(Maybe Int, Char)]
    parseMembers :: String -> [(Maybe Int, Char)]
parseMembers String
s = case Parser [(Maybe Int, Char)]
-> ByteString -> Either String [(Maybe Int, Char)]
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser [(Maybe Int, Char)]
lang (String -> ByteString
BS.pack String
s) of
                       Left String
err -> String -> [(Maybe Int, Char)]
forall a. HasCallStack => String -> a
error (String
"can't calcsize " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)
                       Right [(Maybe Int, Char)]
xs -> [(Maybe Int, Char)]
xs

    lang :: Parser [(Maybe Int, Char)]
lang = Parser ByteString (Maybe Int, Char) -> Parser [(Maybe Int, Char)]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser ByteString (Maybe Int, Char) -> Parser [(Maybe Int, Char)])
-> Parser ByteString (Maybe Int, Char)
-> Parser [(Maybe Int, Char)]
forall a b. (a -> b) -> a -> b
$ (,) (Maybe Int -> Char -> (Maybe Int, Char))
-> Parser ByteString (Maybe Int)
-> Parser ByteString (Char -> (Maybe Int, Char))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int -> Parser ByteString (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString Int
forall a. Integral a => Parser a
decimal Parser ByteString (Char -> (Maybe Int, Char))
-> Parser ByteString Char -> Parser ByteString (Maybe Int, Char)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Char -> Bool) -> Parser ByteString Char
satisfy ((Char -> Bool) -> Parser ByteString Char)
-> (Char -> Bool) -> Parser ByteString Char
forall a b. (a -> b) -> a -> b
$ String -> Char -> Bool
inClass (String -> Char -> Bool) -> String -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Map Char Int -> String
forall k a. Map k a -> [k]
M.keys Map Char Int
sizeM)

xBinopToPyOp :: X.Binop -> Op
xBinopToPyOp :: Binop -> Op
xBinopToPyOp Binop
X.Add = Op
Plus
xBinopToPyOp Binop
X.Sub = Op
Minus
xBinopToPyOp Binop
X.Mult = Op
Multiply
xBinopToPyOp Binop
X.Div = Op
FloorDivide
xBinopToPyOp Binop
X.And = Op
BinaryAnd
xBinopToPyOp Binop
X.RShift = Op
ShiftRight

xUnopToPyOp :: X.Unop -> Op
xUnopToPyOp :: Unop -> Op
xUnopToPyOp Unop
X.Complement = Op
Invert

xExpressionToNestedPyExpr :: (String -> String) -> XExpression -> Expr
xExpressionToNestedPyExpr :: ShowS -> XExpression -> Expr
xExpressionToNestedPyExpr ShowS
acc (Op Binop
o XExpression
e1 XExpression
e2) =
  Expr -> Expr
Paren (ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
acc (Binop -> XExpression -> XExpression -> XExpression
forall typ.
Binop -> Expression typ -> Expression typ -> Expression typ
Op Binop
o XExpression
e1 XExpression
e2))
xExpressionToNestedPyExpr ShowS
acc XExpression
xexpr =
  ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
acc XExpression
xexpr

xExpressionToPyExpr :: (String -> String) -> XExpression -> Expr
xExpressionToPyExpr :: ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
_ (Value Int
i) = Int -> Expr
Int Int
i
xExpressionToPyExpr ShowS
_ (Bit Int
i) = Op -> Expr -> Expr -> Expr
BinaryOp Op
ShiftLeft (Int -> Expr
Int Int
1) (Int -> Expr
Int Int
i)
xExpressionToPyExpr ShowS
acc (FieldRef String
n) = String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ ShowS
acc String
n
xExpressionToPyExpr ShowS
_ (EnumRef (UnQualType String
enum) String
n) = String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
enum String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n
-- Currently xcb only uses unqualified types, not sure how qualtype should behave
xExpressionToPyExpr ShowS
_ (EnumRef (QualType String
ext String
n) String
_) = String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
ext String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n
xExpressionToPyExpr ShowS
acc (PopCount XExpression
e) =
  String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"xcffib.popcount" [ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
acc XExpression
e]
-- http://cgit.freedesktop.org/xcb/proto/tree/doc/xml-xcb.txt#n290
xExpressionToPyExpr ShowS
acc (SumOf String
n) = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"sum" [String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ ShowS
acc String
n]
xExpressionToPyExpr ShowS
acc (Op Binop
o XExpression
e1 XExpression
e2) =
  let o' :: Op
o' = Binop -> Op
xBinopToPyOp Binop
o
      e1' :: Expr
e1' = ShowS -> XExpression -> Expr
xExpressionToNestedPyExpr ShowS
acc XExpression
e1
      e2' :: Expr
e2' = ShowS -> XExpression -> Expr
xExpressionToNestedPyExpr ShowS
acc XExpression
e2
  in Op -> Expr -> Expr -> Expr
BinaryOp Op
o' Expr
e1' Expr
e2'
xExpressionToPyExpr ShowS
acc (Unop Unop
o XExpression
e) =
  let o' :: Op
o' = Unop -> Op
xUnopToPyOp Unop
o
      e' :: Expr
e' = ShowS -> XExpression -> Expr
xExpressionToNestedPyExpr ShowS
acc XExpression
e
  in Expr -> Expr
Paren (Op -> Expr -> Expr
UnaryOp Op
o' Expr
e')
xExpressionToPyExpr ShowS
acc (ParamRef String
n) =
    if String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"num_axes"
    then String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ ShowS
acc String
n
    else String -> Expr
forall a. HasCallStack => String -> a
error (String
"unsupported paramref " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n)

getConst :: XExpression -> Maybe Int
getConst :: XExpression -> Maybe Int
getConst (Value Int
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
getConst (Bit Int
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Bits a => Int -> a
bit Int
i
getConst (Op Binop
o XExpression
e1 XExpression
e2) = do
  Int
c1 <- XExpression -> Maybe Int
getConst XExpression
e1
  Int
c2 <- XExpression -> Maybe Int
getConst XExpression
e2
  Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ case Binop
o of
             Binop
X.Add -> Int
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c2
             Binop
X.Sub -> Int
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c2
             Binop
X.Mult -> Int
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
c2
             Binop
X.Div -> Int
c1 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
c2
             Binop
X.And -> Int
c1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
c2
             Binop
X.RShift -> Int
c1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` Int
c2
getConst (Unop Unop
o XExpression
e) = do
  Int
c <- XExpression -> Maybe Int
getConst XExpression
e
  Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ case Unop
o of
             Unop
X.Complement -> Int -> Int
forall a. Bits a => a -> a
complement Int
c
getConst (PopCount XExpression
e) = (Int -> Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Int
forall a. Bits a => a -> Int
popCount (Maybe Int -> Maybe Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ XExpression -> Maybe Int
getConst XExpression
e
getConst XExpression
_ = Maybe Int
forall a. Maybe a
Nothing

xEnumElemsToPyEnum :: (String -> String) -> [XEnumElem] -> [(String, Expr)]
xEnumElemsToPyEnum :: ShowS -> [XEnumElem] -> [(String, Expr)]
xEnumElemsToPyEnum ShowS
accessor [XEnumElem]
membs = [(String, Expr)] -> [(String, Expr)]
forall a. [a] -> [a]
reverse ([(String, Expr)] -> [(String, Expr)])
-> [(String, Expr)] -> [(String, Expr)]
forall a b. (a -> b) -> a -> b
$ [XEnumElem] -> [(String, Expr)] -> [Int] -> [(String, Expr)]
conv [XEnumElem]
membs [] [Int
0..]
  where
    exprConv :: XExpression -> Expr
exprConv = ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
accessor
    conv :: [XEnumElem] -> [(String, Expr)] -> [Int] -> [(String, Expr)]
    conv :: [XEnumElem] -> [(String, Expr)] -> [Int] -> [(String, Expr)]
conv ((EnumElem String
name Maybe XExpression
expr) : [XEnumElem]
els) [(String, Expr)]
acc [Int]
is =
      let expr' :: Expr
expr' = Expr -> Maybe Expr -> Expr
forall a. a -> Maybe a -> a
fromMaybe (Int -> Expr
Int ([Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
is)) (Maybe Expr -> Expr) -> Maybe Expr -> Expr
forall a b. (a -> b) -> a -> b
$ (XExpression -> Expr) -> Maybe XExpression -> Maybe Expr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap XExpression -> Expr
exprConv Maybe XExpression
expr
          is' :: [Int]
is' = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Expr -> Int
int_value Expr
expr'))) [Int]
is
          acc' :: [(String, Expr)]
acc' = (String
name, Expr
expr') (String, Expr) -> [(String, Expr)] -> [(String, Expr)]
forall a. a -> [a] -> [a]
: [(String, Expr)]
acc
      in [XEnumElem] -> [(String, Expr)] -> [Int] -> [(String, Expr)]
conv [XEnumElem]
els [(String, Expr)]
acc' [Int]
is'
    conv [] [(String, Expr)]
acc [Int]
_ = [(String, Expr)]
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 :: String -> ShowS
addStructData String
prefix (Char
c : String
cs) | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"Bbx" =
  let result :: String
result = String -> Char -> String
maybePrintChar String
prefix Char
c
  in if String
result String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
prefix then String
result String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs) else String
result String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cs
addStructData String
prefix String
s = (String -> Char -> String
maybePrintChar String
prefix Char
'x') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

maybePrintChar :: String -> Char -> String
maybePrintChar :: String -> Char -> String
maybePrintChar String
s Char
c | String
"%c" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s = String -> Char -> String
forall r. PrintfType r => String -> r
printf String
s Char
c
maybePrintChar String
s Char
_ = String
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 :: Int -> String
mkPad Int
1 = String
"x"
mkPad Int
i = (Int -> String
forall a. Show a => a -> String
show Int
i) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"x"

structElemToPyUnpack :: Expr
                     -> String
                     -> TypeInfoMap
                     -> GenStructElem Type
                     -> Either (Maybe String, String)
                               (String, Either (Expr, Expr)
                                               ([(Expr, [GenStructElem Type])]), Maybe Int)
structElemToPyUnpack :: Expr
-> String
-> TypeInfoMap
-> GenStructElem Type
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
structElemToPyUnpack Expr
_ String
_ TypeInfoMap
_ (Pad PadType
PadBytes Int
i) = (Maybe String, String)
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a b. a -> Either a b
Left (Maybe String
forall a. Maybe a
Nothing, Int -> String
mkPad Int
i)
structElemToPyUnpack Expr
_ String
_ TypeInfoMap
_ (Pad PadType
PadAlignment Int
_) = (Maybe String, String)
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a b. a -> Either a b
Left (Maybe String
forall a. Maybe a
Nothing, String
"")

-- XXX: This is a cheap hack for noop, we should really do better.
structElemToPyUnpack Expr
_ String
_ TypeInfoMap
_ (Doc Maybe String
_ Map String String
_ [(String, String)]
_) = (Maybe String, String)
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a b. a -> Either a b
Left (Maybe String
forall a. Maybe a
Nothing, String
"")
-- XXX: What does fd mean? we should implement it correctly
structElemToPyUnpack Expr
_ String
_ TypeInfoMap
_ (Fd String
_) = (Maybe String, String)
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a b. a -> Either a b
Left (Maybe String
forall a. Maybe a
Nothing, String
"")
structElemToPyUnpack Expr
_ String
_ TypeInfoMap
_ (Length Type
_ XExpression
_) = (Maybe String, String)
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a b. a -> Either a b
Left (Maybe String
forall a. Maybe a
Nothing, String
"")

-- The switch fields pick the way to expression to pack based on the expression
structElemToPyUnpack Expr
_ String
_ TypeInfoMap
_ (Switch String
name XExpression
expr Maybe Alignment
_ [GenBitCase Type]
bitcases) =
  let cmp :: Expr
cmp = ShowS -> XExpression -> Expr
xExpressionToPyExpr (String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"self.") XExpression
expr
      switch :: [(Expr, [GenStructElem Type])]
switch = (GenBitCase Type -> (Expr, [GenStructElem Type]))
-> [GenBitCase Type] -> [(Expr, [GenStructElem Type])]
forall a b. (a -> b) -> [a] -> [b]
map (Expr -> GenBitCase Type -> (Expr, [GenStructElem Type])
mkSwitch Expr
cmp) [GenBitCase Type]
bitcases
  in (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
 Maybe Int)
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a b. b -> Either a b
Right (String
name, [(Expr, [GenStructElem Type])]
-> Either (Expr, Expr) [(Expr, [GenStructElem Type])]
forall a b. b -> Either a b
Right [(Expr, [GenStructElem Type])]
switch, Maybe Int
forall a. Maybe a
Nothing)
    where
      mkSwitch :: Expr
               -> BitCase
               -> (Expr, [GenStructElem Type])
      mkSwitch :: Expr -> GenBitCase Type -> (Expr, [GenStructElem Type])
mkSwitch Expr
cmp (BitCase Maybe String
Nothing [XExpression]
bcCmp Maybe Alignment
_ [GenStructElem Type]
elems) =
        -- 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 :: Expr
cmpVal = ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
forall a. a -> a
id ([XExpression] -> XExpression
forall a. HasCallStack => [a] -> a
head [XExpression]
bcCmp)
            equality :: Expr
equality = Op -> Expr -> Expr -> Expr
BinaryOp Op
BinaryAnd Expr
cmp Expr
cmpVal
        in (Expr
equality, [GenStructElem Type]
elems)

      mkSwitch Expr
cmp (BitCase (Just String
_) [XExpression]
bcCmp Maybe Alignment
_ [GenStructElem Type]
elems) =
        let cmpVal :: Expr
cmpVal = ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
forall a. a -> a
id ([XExpression] -> XExpression
forall a. HasCallStack => [a] -> a
head [XExpression]
bcCmp)
            equality :: Expr
equality = Op -> Expr -> Expr -> Expr
BinaryOp Op
Equality Expr
cmp Expr
cmpVal
        in (Expr
equality, [GenStructElem Type]
elems)

-- The enum field is mostly for user information, so we ignore it.
structElemToPyUnpack Expr
unpacker String
ext TypeInfoMap
m (X.List String
n Type
typ Maybe XExpression
len Maybe Type
_) =
  let attr :: ShowS
attr = (String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"self.")
      len' :: Expr
len' = Expr -> Maybe Expr -> Expr
forall a. a -> Maybe a -> a
fromMaybe Expr
None (Maybe Expr -> Expr) -> Maybe Expr -> Expr
forall a b. (a -> b) -> a -> b
$ (XExpression -> Expr) -> Maybe XExpression -> Maybe Expr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
attr) Maybe XExpression
len
      cons :: Expr
cons = case TypeInfoMap
m TypeInfoMap -> Type -> TypeInfo
forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
               BaseType String
c -> String -> Expr
mkStr String
c
               CompositeType String
tExt String
c | String
ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
tExt -> String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
tExt String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c
               CompositeType String
_ String
"DeviceTimeCoord" ->
                 let wrapper :: Expr
wrapper = String -> Expr
mkName String
"xcffib.__DeviceTimeCoord_wrapper"
                 in Expr -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall Expr
wrapper [String -> Expr
mkName String
"DeviceTimeCoord", String -> Expr
mkName (ShowS
attr String
"num_axes")]
               CompositeType String
_ String
c -> String -> Expr
mkName String
c
      list :: Expr
list = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"xcffib.List" [ Expr
unpacker
                                  , Expr
cons
                                  , Expr
len'
                                  ]
      constLen :: Maybe Int
constLen = do
        XExpression
l <- Maybe XExpression
len
        XExpression -> Maybe Int
getConst XExpression
l
  in (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
 Maybe Int)
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a b. b -> Either a b
Right (String
n, (Expr, Expr) -> Either (Expr, Expr) [(Expr, [GenStructElem Type])]
forall a b. a -> Either a b
Left (Expr
list, Expr
cons), Maybe Int
constLen)

-- The mask and enum fields are for user information, we can ignore them here.
structElemToPyUnpack Expr
unpacker String
ext TypeInfoMap
m (SField String
n Type
typ Maybe Type
_ Maybe Type
_) =
  case TypeInfoMap
m TypeInfoMap -> Type -> TypeInfo
forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
    BaseType String
c -> (Maybe String, String)
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a b. a -> Either a b
Left (String -> Maybe String
forall a. a -> Maybe a
Just String
n, String
c)
    CompositeType String
tExt String
c ->
      let c' :: String
c' = if String
tExt String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ext then String
c else String
tExt String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c
          field :: Expr
field = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
c' [Expr
unpacker]
      -- TODO: Ugh. Nothing here is wrong. Do we really need to carry the
      -- length of these things around?
      in (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
 Maybe Int)
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a b. b -> Either a b
Right (String
n, (Expr, Expr) -> Either (Expr, Expr) [(Expr, [GenStructElem Type])]
forall a b. a -> Either a b
Left (Expr
field, String -> Expr
mkName String
c'), Maybe Int
forall a. Maybe a
Nothing)
structElemToPyUnpack Expr
_ String
_ TypeInfoMap
_ (ExprField String
_ Type
_ XExpression
_) = String
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a. HasCallStack => String -> a
error String
"Only valid for requests"
structElemToPyUnpack Expr
_ String
_ TypeInfoMap
_ (ValueParam Type
_ String
_ Maybe Int
_ String
_) = String
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
forall a. HasCallStack => String -> a
error String
"Only valid for requests"

structElemToPyPack :: String
                   -> TypeInfoMap
                   -> (String -> String)
                   -> GenStructElem Type
                   -> Either (Maybe String, String) [(String, Either (Maybe (Expr))
                                                                     [(Expr, [GenStructElem Type])]
                                                    )]
structElemToPyPack :: String
-> TypeInfoMap
-> ShowS
-> GenStructElem Type
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
structElemToPyPack String
_ TypeInfoMap
_ ShowS
_ (Pad PadType
_ Int
i) = (Maybe String, String)
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. a -> Either a b
Left (Maybe String
forall a. Maybe a
Nothing, Int -> String
mkPad Int
i)
-- TODO: implement these?
structElemToPyPack String
_ TypeInfoMap
_ ShowS
_ (Doc Maybe String
_ Map String String
_ [(String, String)]
_) = (Maybe String, String)
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. a -> Either a b
Left (Maybe String
forall a. Maybe a
Nothing, String
"")
structElemToPyPack String
_ TypeInfoMap
_ ShowS
_ (Fd String
_) = (Maybe String, String)
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. a -> Either a b
Left (Maybe String
forall a. Maybe a
Nothing, String
"")
structElemToPyPack String
_ TypeInfoMap
_ ShowS
_ (Length Type
_ XExpression
_) = (Maybe String, String)
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. a -> Either a b
Left (Maybe String
forall a. Maybe a
Nothing, String
"")
structElemToPyPack String
_ TypeInfoMap
_ ShowS
accessor (Switch String
n XExpression
expr Maybe Alignment
_ [GenBitCase Type]
bitcases) =
  let name :: String
name = ShowS
accessor String
n
      cmp :: Expr
cmp = ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
accessor XExpression
expr
      elems :: [(Expr, [GenStructElem Type])]
elems = (GenBitCase Type -> (Expr, [GenStructElem Type]))
-> [GenBitCase Type] -> [(Expr, [GenStructElem Type])]
forall a b. (a -> b) -> [a] -> [b]
map (Expr -> GenBitCase Type -> (Expr, [GenStructElem Type])
mkSwitch Expr
cmp) [GenBitCase Type]
bitcases
  in [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. b -> Either a b
Right ([(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. (a -> b) -> a -> b
$ [(String
name, [(Expr, [GenStructElem Type])]
-> Either (Maybe Expr) [(Expr, [GenStructElem Type])]
forall a b. b -> Either a b
Right [(Expr, [GenStructElem Type])]
elems)]
    where
      mkSwitch :: Expr
               -> BitCase
               -> (Expr, [GenStructElem Type])
      mkSwitch :: Expr -> GenBitCase Type -> (Expr, [GenStructElem Type])
mkSwitch Expr
cmp (BitCase Maybe String
_ [XExpression]
bcCmp Maybe Alignment
_ [GenStructElem Type]
elems') =
        -- see comment above about head for BitCase
        let cmpVal :: Expr
cmpVal = ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
accessor ([XExpression] -> XExpression
forall a. HasCallStack => [a] -> a
head [XExpression]
bcCmp)
            equality :: Expr
equality = Op -> Expr -> Expr -> Expr
BinaryOp Op
BinaryAnd Expr
cmp Expr
cmpVal
        in (Expr
equality, [GenStructElem Type]
elems')
structElemToPyPack String
ext TypeInfoMap
m ShowS
accessor (SField String
n Type
typ Maybe Type
_ Maybe Type
_) =
  let name :: String
name = ShowS
accessor String
n
  in case TypeInfoMap
m TypeInfoMap -> Type -> TypeInfo
forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
       BaseType String
c -> (Maybe String, String)
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. a -> Either a b
Left (String -> Maybe String
forall a. a -> Maybe a
Just String
name, String
c)
       CompositeType String
tExt String
typNam ->
         let cond :: Expr
cond = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"hasattr" [String -> Expr
mkName String
name, (String -> Expr
mkStr String
"pack")]
             trueB :: Expr
trueB = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".pack") []
             typNam' :: String
typNam' = if String
ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
tExt then String
typNam else String
tExt String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
typNam
             synthetic :: Expr
synthetic = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall (String
typNam' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".synthetic") [String -> Expr
mkName (String
"*" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name)]
             falseB :: Expr
falseB = Expr -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall (Expr -> String -> Expr
forall a. PseudoExpr a => a -> String -> Expr
mkDot Expr
synthetic String
"pack") []
         in [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. b -> Either a b
Right ([(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. (a -> b) -> a -> b
$ [(String
name
                    , Maybe Expr -> Either (Maybe Expr) [(Expr, [GenStructElem Type])]
forall a b. a -> Either a b
Left (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Expr -> Expr -> Expr
CondExpr Expr
trueB Expr
cond Expr
falseB))
                    )]
-- TODO: assert values are in enum?
structElemToPyPack String
ext TypeInfoMap
m ShowS
accessor (X.List String
n Type
typ Maybe XExpression
expr Maybe Type
_) =
  let name :: String
name = ShowS
accessor String
n
      -- The convention seems to be either to have a <fieldref> nested in the
      -- list, or use "%s_len" % name if there is no fieldref. We need to add
      -- the _len to the arguments of the function but we don't need to pack
      -- anything, which we denote using Nothing
      list_len :: [(String, Either (Maybe a) b)]
list_len = if Maybe XExpression -> Bool
forall a. Maybe a -> Bool
isNothing Maybe XExpression
expr then [(String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_len", Maybe a -> Either (Maybe a) b
forall a b. a -> Either a b
Left Maybe a
forall a. Maybe a
Nothing)] else []
      list :: [(String, Either (Maybe Expr) b)]
list = case TypeInfoMap
m TypeInfoMap -> Type -> TypeInfo
forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
        BaseType String
c -> [(String
name
                      , Maybe Expr -> Either (Maybe Expr) b
forall a b. a -> Either a b
Left (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"xcffib.pack_list" [ String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
name
                                                              , String -> Expr
mkStr String
c
                                                              ]))
                      )]
        CompositeType String
tExt String
c ->
          let c' :: String
c' = if String
tExt String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ext then String
c else (String
tExt String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c)
          in [(String
name
             , Maybe Expr -> Either (Maybe Expr) b
forall a b. a -> Either a b
Left (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"xcffib.pack_list" ([ String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
name
                                                      , String -> Expr
mkName String
c'
                                                      ])))
             )]
  in [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. b -> Either a b
Right ([(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. (a -> b) -> a -> b
$ [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall {a} {b}. [(String, Either (Maybe a) b)]
list_len [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a. [a] -> [a] -> [a]
++ [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall {b}. [(String, Either (Maybe Expr) b)]
list
structElemToPyPack String
_ TypeInfoMap
m ShowS
accessor (ExprField String
name Type
typ XExpression
expr) =
  let e :: Expr
e = (ShowS -> XExpression -> Expr
xExpressionToPyExpr ShowS
accessor) XExpression
expr
      name' :: String
name' = ShowS
accessor String
name
  in case TypeInfoMap
m TypeInfoMap -> Type -> TypeInfo
forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
       BaseType String
c -> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. b -> Either a b
Right ([(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. (a -> b) -> a -> b
$ [(String
name'
                             , Maybe Expr -> Either (Maybe Expr) [(Expr, [GenStructElem Type])]
forall a b. a -> Either a b
Left (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"struct.pack" [ String -> Expr
mkStr (Char
'=' Char -> ShowS
forall a. a -> [a] -> [a]
: String
c)
                                                                , Expr
e
                                                                ]))
                             )]
       CompositeType String
_ String
_ -> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. b -> Either a b
Right ([(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. (a -> b) -> a -> b
$ [(String
name'
                                    , Maybe Expr -> Either (Maybe Expr) [(Expr, [GenStructElem Type])]
forall a b. a -> Either a b
Left (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall (Expr -> String -> Expr
forall a. PseudoExpr a => a -> String -> Expr
mkDot Expr
e String
"pack") []))
                                    )]

-- As near as I can tell here the padding param is unused.
structElemToPyPack String
_ TypeInfoMap
m ShowS
accessor (ValueParam Type
typ String
mask Maybe Int
_ String
list) =
  case TypeInfoMap
m TypeInfoMap -> Type -> TypeInfo
forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
    BaseType String
c ->
      let mask' :: Expr
mask' = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"struct.pack" [String -> Expr
mkStr (Char
'=' Char -> ShowS
forall a. a -> [a] -> [a]
: String
c), String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ ShowS
accessor String
mask]
          list' :: Expr
list' = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"xcffib.pack_list" [ String -> Expr
mkName (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ ShowS
accessor String
list
                                            , String -> Expr
mkStr String
"I"
                                            ]
      in [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. b -> Either a b
Right ([(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. (a -> b) -> a -> b
$ [(String
mask, Maybe Expr -> Either (Maybe Expr) [(Expr, [GenStructElem Type])]
forall a b. a -> Either a b
Left (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
mask')), (String
list, Maybe Expr -> Either (Maybe Expr) [(Expr, [GenStructElem Type])]
forall a b. a -> Either a b
Left (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
list'))]
    CompositeType String
_ String
_ -> String
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a. HasCallStack => String -> a
error (
      String
"ValueParams other than CARD{16,32} not allowed.")

buf :: Suite
buf :: Suite
buf = [String -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign String
"buf" (String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"io.BytesIO" [])]

mkPackStmts :: String
            -> String
            -> TypeInfoMap
            -> (String -> String)
            -> String
            -> [GenStructElem Type]
            -> ([String], Suite)
mkPackStmts :: String
-> String
-> TypeInfoMap
-> ShowS
-> String
-> [GenStructElem Type]
-> ([String], Suite)
mkPackStmts String
ext String
name TypeInfoMap
m ShowS
accessor String
prefix [GenStructElem Type]
membs =
  let packF :: GenStructElem Type
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
packF = String
-> TypeInfoMap
-> ShowS
-> GenStructElem Type
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
structElemToPyPack String
ext TypeInfoMap
m ShowS
accessor
      ([Either
   (Maybe String, String)
   [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
toPack, [Either
   (Maybe String, String)
   [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
stmts) = (Either
   (Maybe String, String)
   [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> Bool)
-> [Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
-> ([Either
       (Maybe String, String)
       [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]],
    [Either
       (Maybe String, String)
       [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Either
  (Maybe String, String)
  [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> Bool
forall a b. Either a b -> Bool
EC.isLeft ([Either
    (Maybe String, String)
    [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
 -> ([Either
        (Maybe String, String)
        [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]],
     [Either
        (Maybe String, String)
        [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]))
-> [Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
-> ([Either
       (Maybe String, String)
       [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]],
    [Either
       (Maybe String, String)
       [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]])
forall a b. (a -> b) -> a -> b
$ (GenStructElem Type
 -> Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> [GenStructElem Type]
-> [Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
forall a b. (a -> b) -> [a] -> [b]
map GenStructElem Type
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
packF [GenStructElem Type]
membs
      stmts' :: [[(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
stmts' = (Either
   (Maybe String, String)
   [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> [Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
-> [[(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
forall a b. (a -> b) -> [a] -> [b]
map (((Maybe String, String)
 -> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> ([(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
    -> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])])
-> Either
     (Maybe String, String)
     [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe String, String)
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall {b}.
(Maybe String, String) -> [(String, Either (Maybe Expr) b)]
mkBasePack [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a. a -> a
id) [Either
   (Maybe String, String)
   [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
stmts
      ([String]
args, [String]
keys) = let ([Maybe String]
as, [String]
ks) = [(Maybe String, String)] -> ([Maybe String], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Either
   (Maybe String, String)
   [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> (Maybe String, String))
-> [Either
      (Maybe String, String)
      [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
-> [(Maybe String, String)]
forall a b. (a -> b) -> [a] -> [b]
map Either
  (Maybe String, String)
  [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> (Maybe String, String)
forall a b. Either a b -> a
EC.fromLeft' [Either
   (Maybe String, String)
   [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
toPack) in ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
as, [String]
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.
      ([String]
listNames, [Either (Maybe Expr) [(Expr, [GenStructElem Type])]]
listOrSwitches) = [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> ([String], [Either (Maybe Expr) [(Expr, [GenStructElem Type])]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> ([String],
     [Either (Maybe Expr) [(Expr, [GenStructElem Type])]]))
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> ([String], [Either (Maybe Expr) [(Expr, [GenStructElem Type])]])
forall a b. (a -> b) -> a -> b
$ ((String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])
 -> Bool)
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> [String] -> Bool) -> [String] -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem [String]
args (String -> Bool)
-> ((String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])
    -> String)
-> (String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])
-> String
forall a b. (a, b) -> a
fst) ([[(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]]
stmts')
      listWrites :: Suite
listWrites = [Suite] -> Suite
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Suite] -> Suite) -> [Suite] -> Suite
forall a b. (a -> b) -> a -> b
$ ((String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])
 -> Suite)
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> [Suite]
forall a b. (a -> b) -> [a] -> [b]
map ((String
 -> Either (Maybe Expr) [(Expr, [GenStructElem Type])] -> Suite)
-> (String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])
-> Suite
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String
-> Either (Maybe Expr) [(Expr, [GenStructElem Type])] -> Suite
mkWrites) ([(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
 -> [Suite])
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
-> [Suite]
forall a b. (a -> b) -> a -> b
$ [String]
-> [Either (Maybe Expr) [(Expr, [GenStructElem Type])]]
-> [(String, Either (Maybe Expr) [(Expr, [GenStructElem Type])])]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
listNames [Either (Maybe Expr) [(Expr, [GenStructElem Type])]]
listOrSwitches
      listNames' :: [String]
listNames' = case (String
ext, String
name) of
                     -- XXX: QueryTextExtents has a field named "odd_length"
                     -- which is unused, let's just drop it.
                     (String
"xproto", String
"QueryTextExtents") ->
                       let notOdd :: String -> Bool
notOdd String
"odd_length" = Bool
False
                           notOdd String
_ = Bool
True
                       in (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
notOdd [String]
listNames
                     (String, String)
_ -> [String]
listNames
      packStr :: String
packStr = String -> ShowS
addStructData String
prefix ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"" [String]
keys
      write :: Expr
write = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"buf.write" [String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"struct.pack"
                                         (String -> Expr
mkStr (Char
'=' Char -> ShowS
forall a. a -> [a] -> [a]
: String
packStr) Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: ((String -> Expr) -> [String] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map String -> Expr
mkName [String]
args))]
      writeStmt :: Suite
writeStmt = if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
packStr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then [Expr -> Statement
StmtExpr Expr
write] else []
  in ([String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
listNames', Suite
writeStmt Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
listWrites)
    where
      mkWrites :: String
               -> Either (Maybe (Expr))
                         [(Expr, [GenStructElem Type])]
               -> Suite
      mkWrites :: String
-> Either (Maybe Expr) [(Expr, [GenStructElem Type])] -> Suite
mkWrites String
_ (Left Maybe Expr
Nothing) = []
      mkWrites String
_ (Left (Just Expr
expr)) = [Expr -> Statement
mkListWrite Expr
expr]
      mkWrites String
valueList (Right [(Expr, [GenStructElem Type])]
condList) =
        let ([Expr]
conds, [[GenStructElem Type]]
exprs) = [(Expr, [GenStructElem Type])] -> ([Expr], [[GenStructElem Type]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Expr, [GenStructElem Type])]
condList
            ([[String]]
names, [Suite]
stmts) = [([String], Suite)] -> ([[String]], [Suite])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([String], Suite)] -> ([[String]], [Suite]))
-> [([String], Suite)] -> ([[String]], [Suite])
forall a b. (a -> b) -> a -> b
$ ([GenStructElem Type] -> ([String], Suite))
-> [[GenStructElem Type]] -> [([String], Suite)]
forall a b. (a -> b) -> [a] -> [b]
map (String
-> String
-> TypeInfoMap
-> ShowS
-> String
-> [GenStructElem Type]
-> ([String], Suite)
mkPackStmts String
ext String
name TypeInfoMap
m ShowS
accessor String
"") [[GenStructElem Type]]
exprs
        in ((Expr, [String], Suite) -> Statement)
-> [(Expr, [String], Suite)] -> Suite
forall a b. (a -> b) -> [a] -> [b]
map (\(Expr
x, [String]
y, Suite
z) -> Expr -> Suite -> Suite -> Statement
Conditional Expr
x ((String -> Statement) -> [String] -> Suite
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Statement
mkPop String
valueList) [String]
y Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
z) []) ([(Expr, [String], Suite)] -> Suite)
-> [(Expr, [String], Suite)] -> Suite
forall a b. (a -> b) -> a -> b
$ [Expr] -> [[String]] -> [Suite] -> [(Expr, [String], Suite)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Expr]
conds [[String]]
names [Suite]
stmts

      mkListWrite :: Expr
                  -> Statement
      mkListWrite :: Expr -> Statement
mkListWrite Expr
expr' = Expr -> Statement
StmtExpr (Expr -> Statement) -> ([Expr] -> Expr) -> [Expr] -> Statement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"buf.write" ([Expr] -> Statement) -> [Expr] -> Statement
forall a b. (a -> b) -> a -> b
$ (Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: []) Expr
expr'

      mkPop :: String
            -> String
            -> Statement
      mkPop :: String -> String -> Statement
mkPop String
toPop String
n =
        let pop :: Expr
pop = Expr -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall (String -> String -> Expr
forall a. PseudoExpr a => a -> String -> Expr
mkDot String
toPop String
"pop") [Int -> Expr
Int Int
0]
        in if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n then Expr -> Statement
StmtExpr Expr
pop else String -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign String
n Expr
pop

      mkBasePack :: (Maybe String, String) -> [(String, Either (Maybe Expr) b)]
mkBasePack (Maybe String
Nothing, String
"") = []
      mkBasePack (Maybe String
n, String
c) =
        let n' :: String
n' = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ShowS
forall a. a -> a
id Maybe String
n
        in [(String
n', Maybe Expr -> Either (Maybe Expr) b
forall a b. a -> Either a b
Left (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"struct.pack" [String -> Expr
mkStr (Char
'=' Char -> ShowS
forall a. a -> [a] -> [a]
: String
c), String -> Expr
mkName String
n'])))]

mkPackMethod :: String
             -> String
             -> TypeInfoMap
             -> Maybe (String, Int)
             -> [GenStructElem Type]
             -> Maybe Int
             -> Statement
mkPackMethod :: String
-> String
-> TypeInfoMap
-> Maybe (String, Int)
-> [GenStructElem Type]
-> Maybe Int
-> Statement
mkPackMethod String
ext String
name TypeInfoMap
m Maybe (String, Int)
prefixAndOp [GenStructElem Type]
structElems Maybe Int
minLen =
  let accessor :: ShowS
accessor = (String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"self.")
      (String
prefix, Suite
op) = case Maybe (String, Int)
prefixAndOp of
                        Just (Char
'x' : String
rest, Int
i) ->
                          let packOpcode :: Expr
packOpcode = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"struct.pack" [String -> Expr
mkStr String
"=B", Int -> Expr
Int Int
i]
                              write :: Expr
write = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"buf.write" [Expr
packOpcode]
                          in (String
rest, [Expr -> Statement
StmtExpr Expr
write])
                        Just (String
rest, Int
_) -> String -> (String, Suite)
forall a. HasCallStack => String -> a
error (String
"internal API error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
rest)
                        Maybe (String, Int)
Nothing -> (String
"", [])
      ([String]
_, Suite
packStmts) = String
-> String
-> TypeInfoMap
-> ShowS
-> String
-> [GenStructElem Type]
-> ([String], Suite)
mkPackStmts String
ext String
name TypeInfoMap
m ShowS
accessor String
prefix [GenStructElem Type]
structElems
      extend :: Suite
extend = [Suite] -> Suite
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Suite] -> Suite) -> [Suite] -> Suite
forall a b. (a -> b) -> a -> b
$ do
        Int
len <- Maybe Int -> [Int]
forall a. Maybe a -> [a]
maybeToList Maybe Int
minLen
        let bufLen :: Expr
bufLen = String -> Expr
mkName String
"buf_len"
            bufLenAssign :: Statement
bufLenAssign = Expr -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign Expr
bufLen (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"len" [String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"buf.getvalue" []]
            test :: Expr
test = (Op -> Expr -> Expr -> Expr
BinaryOp Op
LessThan Expr
bufLen (Int -> Expr
Int Int
len))
            bufWriteLen :: Expr
bufWriteLen = Expr -> Expr
Paren (Op -> Expr -> Expr -> Expr
BinaryOp Op
Minus (Int -> Expr
Int Int
32) Expr
bufLen)
            extraPackFmt :: Expr
extraPackFmt = Expr -> Expr
Paren (Op -> Expr -> Expr -> Expr
BinaryOp Op
Modulo (String -> Expr
mkStr String
"%dx") Expr
bufWriteLen)
            extra :: Expr
extra = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"struct.pack" [Expr
extraPackFmt]
            writeExtra :: Suite
writeExtra = [Expr -> Statement
StmtExpr (String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"buf.write" [Expr
extra])]
        Suite -> [Suite]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Suite -> [Suite]) -> Suite -> [Suite]
forall a b. (a -> b) -> a -> b
$ [Statement
bufLenAssign, Expr -> Suite -> Statement
mkIf Expr
test Suite
writeExtra]
      ret :: Suite
ret = [Expr -> Statement
mkReturn (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"buf.getvalue" []]
  in String -> [String] -> Suite -> Statement
mkMethod String
"pack" [String
"self"] (Suite -> Statement) -> Suite -> Statement
forall a b. (a -> b) -> a -> b
$ Suite
buf Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
op Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
packStmts Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
extend Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
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.
  StructUnpackState -> Bool
stNeedsPad :: Bool,

  -- The list of names the struct.pack accumulator has, and the
  StructUnpackState -> [String]
stNames :: [String],

  -- The list of pack directives (potentially with a "%c" in it for
  -- the prefix byte).
  StructUnpackState -> String
stPacks :: String
}

-- | Make a struct style (i.e. not union style) unpack.
mkStructStyleUnpack :: String
                    -> String
                    -> TypeInfoMap
                    -> [GenStructElem Type]
                    -> (Suite, Maybe Int)
mkStructStyleUnpack :: String
-> String
-> TypeInfoMap
-> [GenStructElem Type]
-> (Suite, Maybe Int)
mkStructStyleUnpack String
prefix String
ext TypeInfoMap
m [GenStructElem Type]
membs =
  let unpacked :: [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
unpacked = (GenStructElem Type
 -> Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int))
-> [GenStructElem Type]
-> [Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Expr
-> String
-> TypeInfoMap
-> GenStructElem Type
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
structElemToPyUnpack (String -> Expr
mkName String
"unpacker") String
ext TypeInfoMap
m) [GenStructElem Type]
membs
      initial :: StructUnpackState
initial = Bool -> [String] -> String -> StructUnpackState
StructUnpackState Bool
False [] String
prefix
      ([String]
_, Suite
unpackStmts, Maybe Int
size) = State StructUnpackState ([String], Suite, Maybe Int)
-> StructUnpackState -> ([String], Suite, Maybe Int)
forall s a. State s a -> s -> a
evalState ([Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
-> State StructUnpackState ([String], Suite, Maybe Int)
mkUnpackStmts [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
unpacked) StructUnpackState
initial
      base :: Suite
base = [String -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign String
"base" (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ String -> Expr
mkName String
"unpacker.offset"]
      bufsize :: Suite
bufsize =
        let rhs :: Expr
rhs = Op -> Expr -> Expr -> Expr
BinaryOp Op
Minus (String -> Expr
mkName String
"unpacker.offset") (String -> Expr
mkName String
"base")
        in [Expr -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign (String -> Expr
mkAttr String
"bufsize") Expr
rhs]
      statements :: Suite
statements = Suite
base Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
unpackStmts Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
bufsize
  in (Suite
statements, Maybe Int
size)

    where
      -- 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)

      mkUnpackStmts :: [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
-> State StructUnpackState ([String], Suite, Maybe Int)
mkUnpackStmts [] = State StructUnpackState ([String], Suite, Maybe Int)
flushAcc

      mkUnpackStmts (Left (Maybe String
name, String
pack) : [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
xs) = do
        StructUnpackState
st <- StateT StructUnpackState Identity StructUnpackState
forall s (m :: * -> *). MonadState s m => m s
get
        let packs :: String
packs = if String
"%c" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` (StructUnpackState -> String
stPacks StructUnpackState
st)
                    then String -> ShowS
addStructData (StructUnpackState -> String
stPacks StructUnpackState
st) String
pack
                    else (StructUnpackState -> String
stPacks StructUnpackState
st) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pack
        StructUnpackState -> StateT StructUnpackState Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (StructUnpackState -> StateT StructUnpackState Identity ())
-> StructUnpackState -> StateT StructUnpackState Identity ()
forall a b. (a -> b) -> a -> b
$ StructUnpackState
st { stNames = stNames st ++ maybeToList name
                 , stPacks = packs
                 }
        [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
-> State StructUnpackState ([String], Suite, Maybe Int)
mkUnpackStmts [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
xs

      mkUnpackStmts (Right (String
thisName, Either (Expr, Expr) [(Expr, [GenStructElem Type])]
listOrSwitch, Maybe Int
thisSz) : [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
xs) = do
        ([String]
packNames, Suite
packStmt, Maybe Int
packSz) <- State StructUnpackState ([String], Suite, Maybe Int)
flushAcc
        StructUnpackState
st <- StateT StructUnpackState Identity StructUnpackState
forall s (m :: * -> *). MonadState s m => m s
get
        StructUnpackState -> StateT StructUnpackState Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (StructUnpackState -> StateT StructUnpackState Identity ())
-> StructUnpackState -> StateT StructUnpackState Identity ()
forall a b. (a -> b) -> a -> b
$ StructUnpackState
st { stNeedsPad = True }
        let thisStmts :: Suite
thisStmts = String
-> Either (Expr, Expr) [(Expr, [GenStructElem Type])]
-> Bool
-> StructUnpackState
-> Suite
mkUnpackListOrSwitch String
thisName Either (Expr, Expr) [(Expr, [GenStructElem Type])]
listOrSwitch (StructUnpackState -> Bool
stNeedsPad StructUnpackState
st) StructUnpackState
st
        ([String]
restNames, Suite
restStmts, Maybe Int
restSz) <- [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
-> State StructUnpackState ([String], Suite, Maybe Int)
mkUnpackStmts [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
xs
        let totalSize :: Maybe Int
totalSize = do
                          Int
before <- Maybe Int
packSz
                          Int
rest <- Maybe Int
restSz
                          Int
thisSz' <- Maybe Int
thisSz
                          Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
before Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rest Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
thisSz'
        ([String], Suite, Maybe Int)
-> State StructUnpackState ([String], Suite, Maybe Int)
forall a. a -> StateT StructUnpackState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [String]
packNames [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
thisName] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
restNames
               , Suite
packStmt Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
thisStmts Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
restStmts
               , Maybe Int
totalSize
               )
          where
            mkUnpackListOrSwitch :: String
                                 -> Either (Expr, Expr)
                                           ([(Expr, [GenStructElem Type])])
                                 -> Bool
                                 -> StructUnpackState
                                 -> Suite
            mkUnpackListOrSwitch :: String
-> Either (Expr, Expr) [(Expr, [GenStructElem Type])]
-> Bool
-> StructUnpackState
-> Suite
mkUnpackListOrSwitch String
name' (Left (Expr
list, Expr
cons)) Bool
needsPad StructUnpackState
_ =
              let pad :: Suite
pad = if Bool
needsPad
                        then [Expr -> Statement
typePad Expr
cons]
                        else []
              in Suite
pad Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ [Expr -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign (String -> Expr
mkAttr String
name') Expr
list]
            mkUnpackListOrSwitch String
_ (Right [(Expr, [GenStructElem Type])]
switchList) Bool
_ StructUnpackState
st' =
              let ([Expr]
conds, [[GenStructElem Type]]
elems) = [(Expr, [GenStructElem Type])] -> ([Expr], [[GenStructElem Type]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Expr, [GenStructElem Type])]
switchList
                  stmts :: [Suite]
stmts = ([GenStructElem Type] -> Suite)
-> [[GenStructElem Type]] -> [Suite]
forall a b. (a -> b) -> [a] -> [b]
map (StructUnpackState -> [GenStructElem Type] -> Suite
mkUnpackSwitchElems StructUnpackState
st') [[GenStructElem Type]]
elems
              in ((Expr, Suite) -> Statement) -> [(Expr, Suite)] -> Suite
forall a b. (a -> b) -> [a] -> [b]
map (\(Expr
cond,Suite
body) -> Expr -> Suite -> Suite -> Statement
Conditional Expr
cond Suite
body []) ([(Expr, Suite)] -> Suite) -> [(Expr, Suite)] -> Suite
forall a b. (a -> b) -> a -> b
$ [Expr] -> [Suite] -> [(Expr, Suite)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr]
conds [Suite]
stmts

            mkUnpackSwitchElems :: StructUnpackState
                                -> [GenStructElem Type]
                                -> Suite
            mkUnpackSwitchElems :: StructUnpackState -> [GenStructElem Type] -> Suite
mkUnpackSwitchElems StructUnpackState
st' [GenStructElem Type]
elems' =
              let unpacked' :: [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
unpacked' = (GenStructElem Type
 -> Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int))
-> [GenStructElem Type]
-> [Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Expr
-> String
-> TypeInfoMap
-> GenStructElem Type
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
structElemToPyUnpack (String -> Expr
mkName String
"unpacker") String
ext TypeInfoMap
m) [GenStructElem Type]
elems'
                  ([String]
_, Suite
stmts', Maybe Int
_) = State StructUnpackState ([String], Suite, Maybe Int)
-> StructUnpackState -> ([String], Suite, Maybe Int)
forall s a. State s a -> s -> a
evalState ([Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
-> State StructUnpackState ([String], Suite, Maybe Int)
mkUnpackStmts [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
unpacked') StructUnpackState
st'
              in Suite
stmts'

      flushAcc :: State StructUnpackState ([String], Suite, Maybe Int)
      flushAcc :: State StructUnpackState ([String], Suite, Maybe Int)
flushAcc = do
        StructUnpackState Bool
needsPad [String]
args String
keys <- StateT StructUnpackState Identity StructUnpackState
forall s (m :: * -> *). MonadState s m => m s
get
        let size :: Int
size = String -> Int
calcsize String
keys
            assign :: Suite
assign = String -> [String] -> String -> Suite
forall a. PseudoExpr a => a -> [String] -> String -> Suite
mkUnpackFrom String
"unpacker" [String]
args String
keys
        StructUnpackState -> StateT StructUnpackState Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (StructUnpackState -> StateT StructUnpackState Identity ())
-> StructUnpackState -> StateT StructUnpackState Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> [String] -> String -> StructUnpackState
StructUnpackState Bool
needsPad [] String
""
        ([String], Suite, Maybe Int)
-> State StructUnpackState ([String], Suite, Maybe Int)
forall a. a -> StateT StructUnpackState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
args, Suite
assign, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
size)

      typePad :: Expr -> Statement
typePad Expr
e = Expr -> Statement
StmtExpr (String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"unpacker.pad" [Expr
e])

-- | Given a (qualified) type name and a target type, generate a TypeInfoMap
-- updater.
mkModify :: String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify :: String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
name TypeInfo
ti TypeInfoMap
m =
  let m' :: TypeInfoMap
m' = [(Type, TypeInfo)] -> TypeInfoMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (String -> Type
UnQualType String
name, TypeInfo
ti)
                      , (String -> String -> Type
QualType String
ext String
name, TypeInfo
ti)
                      ]
  in TypeInfoMap -> TypeInfoMap -> TypeInfoMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union TypeInfoMap
m TypeInfoMap
m'

mkSyntheticMethod :: [GenStructElem Type] -> [Statement]
mkSyntheticMethod :: [GenStructElem Type] -> Suite
mkSyntheticMethod [GenStructElem Type]
membs = do
  let names :: [String]
names = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ (GenStructElem Type -> Maybe String)
-> [GenStructElem Type] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map GenStructElem Type -> Maybe String
getName [GenStructElem Type]
membs
      args :: [String]
args = String
"cls" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
names
      self :: Statement
self = String -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign String
"self" (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ Expr -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall (String -> String -> Expr
forall a. PseudoExpr a => a -> String -> Expr
mkDot String
"cls" String
"__new__") [String -> Expr
mkName String
"cls"]
      body :: Suite
body = (String -> Statement) -> [String] -> Suite
forall a b. (a -> b) -> [a] -> [b]
map String -> Statement
assign [String]
names
      ret :: Statement
ret = Expr -> Statement
mkReturn (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ String -> Expr
mkName String
"self"
      synthetic :: Statement
synthetic = String -> String -> [String] -> Suite -> Statement
Decorated String
"classmethod" String
"synthetic" [String]
args (Suite -> Statement) -> Suite -> Statement
forall a b. (a -> b) -> a -> b
$ (Statement
self Statement -> Suite -> Suite
forall a. a -> [a] -> [a]
: Suite
body) Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ [Statement
ret]
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
names then [] else [Statement
synthetic]
    where
      getName :: GenStructElem Type -> Maybe String
      getName :: GenStructElem Type -> Maybe String
getName (Pad PadType
_ Int
_) = Maybe String
forall a. Maybe a
Nothing
      getName (X.List String
n Type
_ Maybe XExpression
_ Maybe Type
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
      getName (SField String
n Type
_ Maybe Type
_ Maybe Type
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
      getName (ExprField String
n Type
_ XExpression
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
      getName (ValueParam Type
_ String
n Maybe Int
_ String
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
      getName (Switch String
n XExpression
_ Maybe Alignment
_ [GenBitCase Type]
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
      getName (Doc Maybe String
_ Map String String
_ [(String, String)]
_) = Maybe String
forall a. Maybe a
Nothing
      getName (Fd String
n) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
      getName (Length Type
_ XExpression
_) = Maybe String
forall a. Maybe a
Nothing

      assign :: String -> Statement
      assign :: String -> Statement
assign String
n = Expr -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign (String -> String -> Expr
forall a. PseudoExpr a => a -> String -> Expr
mkDot String
"self" String
n) (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ String -> Expr
mkName String
n

processXDecl :: String
             -> XDecl
             -> State TypeInfoMap BindingPart
processXDecl :: String -> XDecl -> StateT TypeInfoMap Identity BindingPart
processXDecl String
ext (XTypeDef String
name Type
typ) =
  do (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ())
-> (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall a b. (a -> b) -> a -> b
$ \TypeInfoMap
m -> String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
name (TypeInfoMap
m TypeInfoMap -> Type -> TypeInfo
forall k a. Ord k => Map k a -> k -> a
M.! Type
typ) TypeInfoMap
m
     BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return BindingPart
Noop
processXDecl String
ext (XidType String
name) =
  -- http://www.markwitmer.com/guile-xcb/doc/guile-xcb/XIDs.html
  do (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ())
-> (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall a b. (a -> b) -> a -> b
$ String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
name (String -> TypeInfo
BaseType String
"I")
     BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return BindingPart
Noop
processXDecl String
_ (XImport String
n) =
  BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (BindingPart -> StateT TypeInfoMap Identity BindingPart)
-> BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a b. (a -> b) -> a -> b
$ Suite -> BindingPart
Declaration [ String -> Statement
mkRelImport String
n]
processXDecl String
_ (XEnum String
name [XEnumElem]
membs) =
  BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (BindingPart -> StateT TypeInfoMap Identity BindingPart)
-> BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a b. (a -> b) -> a -> b
$ Suite -> BindingPart
Declaration [String -> [(String, Expr)] -> Statement
mkEnum String
name ([(String, Expr)] -> Statement) -> [(String, Expr)] -> Statement
forall a b. (a -> b) -> a -> b
$ ShowS -> [XEnumElem] -> [(String, Expr)]
xEnumElemsToPyEnum ShowS
forall a. a -> a
id [XEnumElem]
membs]
processXDecl String
ext (XStruct String
n Maybe Alignment
_ [GenStructElem Type]
membs) = do
  TypeInfoMap
m <- StateT TypeInfoMap Identity TypeInfoMap
forall s (m :: * -> *). MonadState s m => m s
get
  let (Suite
statements, Maybe Int
len) = String
-> String
-> TypeInfoMap
-> [GenStructElem Type]
-> (Suite, Maybe Int)
mkStructStyleUnpack String
"" String
ext TypeInfoMap
m [GenStructElem Type]
membs
      pack :: Statement
pack = String
-> String
-> TypeInfoMap
-> Maybe (String, Int)
-> [GenStructElem Type]
-> Maybe Int
-> Statement
mkPackMethod String
ext String
n TypeInfoMap
m Maybe (String, Int)
forall a. Maybe a
Nothing [GenStructElem Type]
membs Maybe Int
forall a. Maybe a
Nothing
      synthetic :: Suite
synthetic = [GenStructElem Type] -> Suite
mkSyntheticMethod [GenStructElem Type]
membs
      fixedLength :: Suite
fixedLength = Maybe Statement -> Suite
forall a. Maybe a -> [a]
maybeToList (Maybe Statement -> Suite) -> Maybe Statement -> Suite
forall a b. (a -> b) -> a -> b
$ do
        Int
theLen <- Maybe Int
len
        let rhs :: Expr
rhs = Int -> Expr
Int Int
theLen
        Statement -> Maybe Statement
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Maybe Statement) -> Statement -> Maybe Statement
forall a b. (a -> b) -> a -> b
$ String -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign String
"fixed_size" Expr
rhs
  (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ())
-> (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall a b. (a -> b) -> a -> b
$ String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
n (String -> String -> TypeInfo
CompositeType String
ext String
n)
  BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (BindingPart -> StateT TypeInfoMap Identity BindingPart)
-> BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a b. (a -> b) -> a -> b
$ Suite -> BindingPart
Declaration [String -> String -> Bool -> Suite -> Suite -> Statement
mkXClass String
n String
"xcffib.Struct" Bool
False Suite
statements (Statement
pack Statement -> Suite -> Suite
forall a. a -> [a] -> [a]
: Suite
fixedLength Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
synthetic)]
processXDecl String
ext (XEvent String
name Int
opcode Maybe Alignment
_ Maybe Bool
xge [GenStructElem Type]
membs Maybe Bool
noSequence) = do
  TypeInfoMap
m <- StateT TypeInfoMap Identity TypeInfoMap
forall s (m :: * -> *). MonadState s m => m s
get
  let cname :: String
cname = String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Event"
      prefix :: String
prefix = if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
noSequence then String
"x" else String
"x%c2x"
      pack :: Statement
pack = String
-> String
-> TypeInfoMap
-> Maybe (String, Int)
-> [GenStructElem Type]
-> Maybe Int
-> Statement
mkPackMethod String
ext String
name TypeInfoMap
m ((String, Int) -> Maybe (String, Int)
forall a. a -> Maybe a
Just (String
prefix, Int
opcode)) [GenStructElem Type]
membs (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
32)
      synthetic :: Suite
synthetic = [GenStructElem Type] -> Suite
mkSyntheticMethod [GenStructElem Type]
membs
      (Suite
statements, Maybe Int
_) = String
-> String
-> TypeInfoMap
-> [GenStructElem Type]
-> (Suite, Maybe Int)
mkStructStyleUnpack String
prefix String
ext TypeInfoMap
m [GenStructElem Type]
membs
      eventsUpd :: Statement
eventsUpd = String -> Int -> String -> Statement
mkDictUpdate String
"_events" Int
opcode String
cname
      isxge :: Bool
isxge = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
xge
      -- xgeexp = mkAssign "xge" (if fromMaybe False xge then (mkName "True") else (mkName "False"))
  BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (BindingPart -> StateT TypeInfoMap Identity BindingPart)
-> BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a b. (a -> b) -> a -> b
$ Suite -> BindingPart
Declaration [ String -> String -> Bool -> Suite -> Suite -> Statement
mkXClass String
cname String
"xcffib.Event" Bool
isxge Suite
statements (Statement
pack Statement -> Suite -> Suite
forall a. a -> [a] -> [a]
: Suite
synthetic)
                       , Statement
eventsUpd
                       ]
processXDecl String
ext (XError String
name Int
opcode Maybe Alignment
_ [GenStructElem Type]
membs) = do
  TypeInfoMap
m <- StateT TypeInfoMap Identity TypeInfoMap
forall s (m :: * -> *). MonadState s m => m s
get
  let cname :: String
cname = String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Error"
      prefix :: String
prefix = String
"xx2x"
      pack :: Statement
pack = String
-> String
-> TypeInfoMap
-> Maybe (String, Int)
-> [GenStructElem Type]
-> Maybe Int
-> Statement
mkPackMethod String
ext String
name TypeInfoMap
m ((String, Int) -> Maybe (String, Int)
forall a. a -> Maybe a
Just (String
prefix, Int
opcode)) [GenStructElem Type]
membs Maybe Int
forall a. Maybe a
Nothing
      (Suite
statements, Maybe Int
_) = String
-> String
-> TypeInfoMap
-> [GenStructElem Type]
-> (Suite, Maybe Int)
mkStructStyleUnpack String
prefix String
ext TypeInfoMap
m [GenStructElem Type]
membs
      errorsUpd :: Statement
errorsUpd = String -> Int -> String -> Statement
mkDictUpdate String
"_errors" Int
opcode String
cname
      alias :: Statement
alias = String -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign (String
"Bad" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name) (String -> Expr
mkName String
cname)
  BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (BindingPart -> StateT TypeInfoMap Identity BindingPart)
-> BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a b. (a -> b) -> a -> b
$ Suite -> BindingPart
Declaration [ String -> String -> Bool -> Suite -> Suite -> Statement
mkXClass String
cname String
"xcffib.Error" Bool
False Suite
statements [Statement
pack]
                       , Statement
alias
                       , Statement
errorsUpd
                       ]
processXDecl String
ext (XRequest String
name Int
opcode Maybe Alignment
_ [GenStructElem Type]
membs Maybe (GenXReply Type)
reply) = do
  TypeInfoMap
m <- StateT TypeInfoMap Identity TypeInfoMap
forall s (m :: * -> *). MonadState s m => m s
get
  let
      -- xtest doesn't seem to use the same packing strategy as everyone else,
      -- but there is no clear indication in the XML as to why that is. yay.
      prefix :: String
prefix = if String
ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"xproto" then String
"xx2x" else String
"x%c2x"
      ([String]
args, Suite
packStmts) = String
-> String
-> TypeInfoMap
-> ShowS
-> String
-> [GenStructElem Type]
-> ([String], Suite)
mkPackStmts String
ext String
name TypeInfoMap
m ShowS
forall a. a -> a
id String
prefix [GenStructElem Type]
membs
      cookieName :: String
cookieName = (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cookie")
      replyDecl :: Suite
replyDecl = [Suite] -> Suite
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Suite] -> Suite) -> [Suite] -> Suite
forall a b. (a -> b) -> a -> b
$ Maybe Suite -> [Suite]
forall a. Maybe a -> [a]
maybeToList (Maybe Suite -> [Suite]) -> Maybe Suite -> [Suite]
forall a b. (a -> b) -> a -> b
$ do
        GenXReply Maybe Alignment
_ [GenStructElem Type]
reply' <- Maybe (GenXReply Type)
reply
        let (Suite
replyStmts, Maybe Int
_) = String
-> String
-> TypeInfoMap
-> [GenStructElem Type]
-> (Suite, Maybe Int)
mkStructStyleUnpack String
"x%c2x4x" String
ext TypeInfoMap
m [GenStructElem Type]
reply'
            replyName :: String
replyName = String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Reply"
            theReply :: Statement
theReply = String -> String -> Bool -> Suite -> Suite -> Statement
mkXClass String
replyName String
"xcffib.Reply" Bool
False Suite
replyStmts []
            replyType :: Statement
replyType = String -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign String
"reply_type" (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ String -> Expr
mkName String
replyName
            cookie :: Statement
cookie = String -> String -> Suite -> Statement
mkClass String
cookieName String
"xcffib.Cookie" [Statement
replyType]
        Suite -> Maybe Suite
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [Statement
theReply, Statement
cookie]

      hasReply :: [Expr]
hasReply = if Suite -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Suite
replyDecl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                 then [String -> Expr
mkName String
cookieName]
                 else []
      -- another hack for not supporting named parameters
      -- argChecked = ArgKeyword (ident "is_checked") (mkName "is_checked")
      argChecked :: Expr
argChecked = String -> Expr
mkName (String
"is_checked=is_checked")
      -- a hack to not have to support separate params/exprs
      -- checkedParam = Param (ident "is_checked") Nothing (Just isChecked)
      checkedParam :: String
checkedParam = String
"is_checked=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Bool -> String
forall a. Show a => a -> String
show (Maybe (GenXReply Type) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (GenXReply Type)
reply))
      allArgs :: [String]
allArgs = (String
"self" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
args)) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
checkedParam]
      ret :: Statement
ret = Expr -> Statement
mkReturn (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"self.send_request" ([ Int -> Expr
Int Int
opcode
                                                   , String -> Expr
mkName String
"buf"
                                                   ]
                                                   [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Expr]
hasReply
                                                   [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Expr
argChecked])
      requestBody :: Suite
requestBody = Suite
buf Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
packStmts Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ [Statement
ret]
      request :: Statement
request = String -> [String] -> Suite -> Statement
mkMethod String
name [String]
allArgs Suite
requestBody
  BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (BindingPart -> StateT TypeInfoMap Identity BindingPart)
-> BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a b. (a -> b) -> a -> b
$ Statement -> Suite -> BindingPart
Request Statement
request Suite
replyDecl
processXDecl String
ext (XUnion String
name Maybe Alignment
_ [GenStructElem Type]
membs) = do
  TypeInfoMap
m <- StateT TypeInfoMap Identity TypeInfoMap
forall s (m :: * -> *). MonadState s m => m s
get
  let unpackF :: GenStructElem Type
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
unpackF = Expr
-> String
-> TypeInfoMap
-> GenStructElem Type
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
structElemToPyUnpack Expr
unpackerCopy String
ext TypeInfoMap
m
      ([Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
fields, [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
listInfo) = (Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)
 -> Bool)
-> [Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int)]
-> ([Either
       (Maybe String, String)
       (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
        Maybe Int)],
    [Either
       (Maybe String, String)
       (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
        Maybe Int)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Either
  (Maybe String, String)
  (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
   Maybe Int)
-> Bool
forall a b. Either a b -> Bool
EC.isLeft ([Either
    (Maybe String, String)
    (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
     Maybe Int)]
 -> ([Either
        (Maybe String, String)
        (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
         Maybe Int)],
     [Either
        (Maybe String, String)
        (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
         Maybe Int)]))
-> [Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int)]
-> ([Either
       (Maybe String, String)
       (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
        Maybe Int)],
    [Either
       (Maybe String, String)
       (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
        Maybe Int)])
forall a b. (a -> b) -> a -> b
$ (GenStructElem Type
 -> Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int))
-> [GenStructElem Type]
-> [Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
map GenStructElem Type
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
unpackF [GenStructElem Type]
membs
      toUnpack :: Suite
toUnpack = [Suite] -> Suite
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Suite] -> Suite) -> [Suite] -> Suite
forall a b. (a -> b) -> a -> b
$ (Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)
 -> Suite)
-> [Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int)]
-> [Suite]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe String, String) -> Suite
mkUnionUnpack ((Maybe String, String) -> Suite)
-> (Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int)
    -> (Maybe String, String))
-> Either
     (Maybe String, String)
     (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
      Maybe Int)
-> Suite
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
  (Maybe String, String)
  (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
   Maybe Int)
-> (Maybe String, String)
forall a b. Either a b -> a
EC.fromLeft') [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
fields
      initMethod :: Suite
initMethod = if (Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)
 -> Bool)
-> [Either
      (Maybe String, String)
      (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
       Maybe Int)]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either
  (Maybe String, String)
  (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
   Maybe Int)
-> Bool
forall a b. Either a b -> Bool
EC.isLeft [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
listInfo
                   then [Statement
notImplemented]
                   else ([Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
-> Suite
forall {a} {b} {b} {c}.
[Either a (String, Either (Expr, b) b, c)] -> Suite
mkListUnpack [Either
   (Maybe String, String)
   (String, Either (Expr, Expr) [(Expr, [GenStructElem Type])],
    Maybe Int)]
listInfo) Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
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 :: Statement
pack = String
-> String
-> TypeInfoMap
-> Maybe (String, Int)
-> [GenStructElem Type]
-> Maybe Int
-> Statement
mkPackMethod String
ext String
name TypeInfoMap
m Maybe (String, Int)
forall a. Maybe a
Nothing [[GenStructElem Type] -> GenStructElem Type
forall a. HasCallStack => [a] -> a
head [GenStructElem Type]
membs] Maybe Int
forall a. Maybe a
Nothing
      decl :: Suite
decl = [String -> String -> Bool -> Suite -> Suite -> Statement
mkXClass String
name String
"xcffib.Union" Bool
False Suite
initMethod [Statement
pack]]
  (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ())
-> (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall a b. (a -> b) -> a -> b
$ String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
name (String -> String -> TypeInfo
CompositeType String
ext String
name)
  BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (BindingPart -> StateT TypeInfoMap Identity BindingPart)
-> BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a b. (a -> b) -> a -> b
$ Suite -> BindingPart
Declaration Suite
decl
  where
    unpackerCopy :: Expr
unpackerCopy = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"unpacker.copy" []
    mkUnionUnpack :: (Maybe String, String)
                  -> Suite
    mkUnionUnpack :: (Maybe String, String) -> Suite
mkUnionUnpack (Maybe String
n, String
typ) =
      Expr -> [String] -> String -> Suite
forall a. PseudoExpr a => a -> [String] -> String -> Suite
mkUnpackFrom Expr
unpackerCopy (Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
n) String
typ

    mkListUnpack :: [Either a (String, Either (Expr, b) b, c)] -> Suite
mkListUnpack [Either a (String, Either (Expr, b) b, c)]
listInfo =
      let listInfo' :: [(String, Either (Expr, b) b, c)]
listInfo' = (Either a (String, Either (Expr, b) b, c)
 -> (String, Either (Expr, b) b, c))
-> [Either a (String, Either (Expr, b) b, c)]
-> [(String, Either (Expr, b) b, c)]
forall a b. (a -> b) -> [a] -> [b]
map Either a (String, Either (Expr, b) b, c)
-> (String, Either (Expr, b) b, c)
forall a b. Either a b -> b
EC.fromRight' [Either a (String, Either (Expr, b) b, c)]
listInfo
          ([String]
names, [Either (Expr, b) b]
listOrSwitches, [c]
_) = [(String, Either (Expr, b) b, c)]
-> ([String], [Either (Expr, b) b], [c])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(String, Either (Expr, b) b, c)]
listInfo'
          ([Expr]
exprs, [b]
_) = [(Expr, b)] -> ([Expr], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Expr, b)] -> ([Expr], [b])) -> [(Expr, b)] -> ([Expr], [b])
forall a b. (a -> b) -> a -> b
$ (Either (Expr, b) b -> (Expr, b))
-> [Either (Expr, b) b] -> [(Expr, b)]
forall a b. (a -> b) -> [a] -> [b]
map Either (Expr, b) b -> (Expr, b)
forall a b. Either a b -> a
EC.fromLeft' [Either (Expr, b) b]
listOrSwitches
          lists :: Suite
lists = ((Expr, Expr) -> Statement) -> [(Expr, Expr)] -> Suite
forall a b. (a -> b) -> [a] -> [b]
map ((Expr -> Expr -> Statement) -> (Expr, Expr) -> Statement
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Expr -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign) ([(Expr, Expr)] -> Suite) -> [(Expr, Expr)] -> Suite
forall a b. (a -> b) -> a -> b
$ [Expr] -> [Expr] -> [(Expr, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((String -> Expr) -> [String] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map String -> Expr
mkAttr [String]
names) [Expr]
exprs
      in Suite
lists

processXDecl String
ext (XidUnion String
name [GenXidUnionElem Type]
_) =
  -- These are always unions of only XIDs.
  do (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ())
-> (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall a b. (a -> b) -> a -> b
$ String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
name (String -> TypeInfo
BaseType String
"I")
     BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return BindingPart
Noop

-- EventStruct basically describes a set of possible events that could be
-- represented by this one member. Slated to land in 1.13, it is only used in
-- SendExtensionEvent for now.
--
-- Rather than do a bunch of work nobody will use, I've punted on this for now,
-- leaving EventStructs as raw buffers. Since we support synthetic creation of
-- events from buffers and SendExtensionEvent has the event types, people can
-- unpack the thing themselves, by using the raw buffer that we keep around in
-- the new Buffer class. Maybe some day in the future someone can add some
-- syntactic sugar to make this a little nicer, but at least things compile
-- again.
processXDecl String
ext (XEventStruct String
name [AllowedEvent]
_) = do
  (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ())
-> (TypeInfoMap -> TypeInfoMap) -> StateT TypeInfoMap Identity ()
forall a b. (a -> b) -> a -> b
$ String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
name (String -> String -> TypeInfo
CompositeType String
ext String
name)
  BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a. a -> StateT TypeInfoMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (BindingPart -> StateT TypeInfoMap Identity BindingPart)
-> BindingPart -> StateT TypeInfoMap Identity BindingPart
forall a b. (a -> b) -> a -> b
$ Suite -> BindingPart
Declaration (Suite -> BindingPart) -> Suite -> BindingPart
forall a b. (a -> b) -> a -> b
$ [String -> String -> Bool -> Suite -> Suite -> Statement
mkXClass String
name String
"xcffib.Buffer" Bool
False [] []]

mkVersion :: XHeader -> Suite
mkVersion :: XHeader -> Suite
mkVersion XHeader
header =
  let major :: Suite
major = String -> Maybe Int -> Suite
ver String
"MAJOR_VERSION" (XHeader -> Maybe Int
forall typ. GenXHeader typ -> Maybe Int
xheader_major_version XHeader
header)
      minor :: Suite
minor = String -> Maybe Int -> Suite
ver String
"MINOR_VERSION" (XHeader -> Maybe Int
forall typ. GenXHeader typ -> Maybe Int
xheader_minor_version XHeader
header)
  in Suite
major Suite -> Suite -> Suite
forall a. [a] -> [a] -> [a]
++ Suite
minor
  where
    ver :: String -> Maybe Int -> Suite
    ver :: String -> Maybe Int -> Suite
ver String
target Maybe Int
i = Maybe Statement -> Suite
forall a. Maybe a -> [a]
maybeToList (Maybe Statement -> Suite) -> Maybe Statement -> Suite
forall a b. (a -> b) -> a -> b
$ (Int -> Statement) -> Maybe Int -> Maybe Statement
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
x -> String -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign String
target (Int -> Expr
Int Int
x)) Maybe Int
i

mkKey :: XHeader -> Maybe (Statement)
mkKey :: XHeader -> Maybe Statement
mkKey XHeader
header = do
  String
name <- XHeader -> Maybe String
forall typ. GenXHeader typ -> Maybe String
xheader_xname XHeader
header
  let call :: Expr
call = String -> [Expr] -> Expr
forall a. PseudoExpr a => a -> [Expr] -> Expr
mkCall String
"xcffib.ExtensionKey" [String -> Expr
mkStr String
name]
  Statement -> Maybe Statement
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Maybe Statement) -> Statement -> Maybe Statement
forall a b. (a -> b) -> a -> b
$ String -> Expr -> Statement
forall a. PseudoExpr a => a -> Expr -> Statement
mkAssign String
"key" Expr
call