{-
 - 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
import Data.Either.Combinators
import Data.List
import qualified Data.Map as M
import Data.Tree
import Data.Maybe
import Data.XCB.FromXML
import Data.XCB.Types as X
import Data.XCB.Python.PyHelpers

import Language.Python.Common as P

import System.FilePath
import System.FilePath.Glob

import Text.Printf

data TypeInfo =
  -- | A "base" X type, i.e. one described in baseTypeInfo; first arg is the
  -- struct.unpack string, second is the size.
  BaseType String |
  -- | A composite type, i.e. a Struct or Union created by XCB. First arg is
  -- the extension that defined it, second is the name of the type.
  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
/= :: TypeInfo -> TypeInfo -> Bool
$c/= :: TypeInfo -> TypeInfo -> Bool
== :: TypeInfo -> TypeInfo -> Bool
$c== :: 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
min :: TypeInfo -> TypeInfo -> TypeInfo
$cmin :: TypeInfo -> TypeInfo -> TypeInfo
max :: TypeInfo -> TypeInfo -> TypeInfo
$cmax :: TypeInfo -> TypeInfo -> TypeInfo
>= :: TypeInfo -> TypeInfo -> Bool
$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
compare :: TypeInfo -> TypeInfo -> Ordering
$ccompare :: TypeInfo -> TypeInfo -> Ordering
$cp1Ord :: Eq 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
showList :: [TypeInfo] -> ShowS
$cshowList :: [TypeInfo] -> ShowS
show :: TypeInfo -> String
$cshow :: TypeInfo -> String
showsPrec :: Int -> TypeInfo -> ShowS
$cshowsPrec :: Int -> 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
showList :: [BindingPart] -> ShowS
$cshowList :: [BindingPart] -> ShowS
show :: BindingPart -> String
$cshow :: BindingPart -> String
showsPrec :: Int -> BindingPart -> ShowS
$cshowsPrec :: Int -> BindingPart -> ShowS
Show)

collectBindings :: [BindingPart] -> (Suite (), Suite ())
collectBindings :: [BindingPart] -> (Suite (), Suite ())
collectBindings = (BindingPart -> (Suite (), Suite ()) -> (Suite (), Suite ()))
-> (Suite (), Suite ()) -> [BindingPart] -> (Suite (), Suite ())
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)
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. [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 ()
mkImport String
"xcffib", String -> Statement ()
mkImport String
"struct", String -> Statement ()
mkImport String
"six"]
          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)
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 (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 (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] -> Forest 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 :: Tree a -> [a]
postOrder (Node a
e Forest 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]) -> Forest a -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Tree a -> [a]
forall a. Tree a -> [a]
postOrder Forest 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 ()) -> () -> Expr () -> Statement ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr () -> () -> Statement ()
forall annot. Expr annot -> annot -> Statement annot
StmtExpr () (Expr () -> Statement ()) -> Expr () -> Statement ()
forall a b. (a -> b) -> a -> b
$ String -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 ()) -> () -> Expr () -> Statement ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr () -> () -> Statement ()
forall annot. Expr annot -> annot -> Statement annot
StmtExpr () (Expr () -> Statement ()) -> Expr () -> Statement ()
forall a b. (a -> b) -> a -> b
$ String -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 (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 (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 (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 -> P.Op ()
xBinopToPyOp :: Binop -> Op ()
xBinopToPyOp Binop
X.Add = () -> Op ()
forall annot. annot -> Op annot
P.Plus ()
xBinopToPyOp Binop
X.Sub = () -> Op ()
forall annot. annot -> Op annot
P.Minus ()
xBinopToPyOp Binop
X.Mult = () -> Op ()
forall annot. annot -> Op annot
P.Multiply ()
xBinopToPyOp Binop
X.Div = () -> Op ()
forall annot. annot -> Op annot
P.FloorDivide ()
xBinopToPyOp Binop
X.And = () -> Op ()
forall annot. annot -> Op annot
P.BinaryAnd ()
xBinopToPyOp Binop
X.RShift = () -> Op ()
forall annot. annot -> Op annot
P.ShiftRight ()

xUnopToPyOp :: X.Unop -> P.Op ()
xUnopToPyOp :: Unop -> Op ()
xUnopToPyOp Unop
X.Complement = () -> Op ()
forall annot. annot -> Op annot
P.Invert ()

xExpressionToNestedPyExpr :: (String -> String) -> XExpression -> Expr ()
xExpressionToNestedPyExpr :: ShowS -> XExpression -> Expr ()
xExpressionToNestedPyExpr ShowS
acc (Op Binop
o XExpression
e1 XExpression
e2) =
  Expr () -> () -> Expr ()
forall annot. Expr annot -> annot -> Expr annot
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 ()
mkInt Int
i
xExpressionToPyExpr ShowS
_ (Bit Int
i) = Op () -> Expr () -> Expr () -> () -> Expr ()
forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (() -> Op ()
forall annot. annot -> Op annot
ShiftLeft ()) (Int -> Expr ()
mkInt Int
1) (Int -> Expr ()
mkInt 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
_ String
_) String
_) = String -> Expr ()
forall a. HasCallStack => String -> a
error String
"Qualified type, unknown behavior"
xExpressionToPyExpr ShowS
acc (PopCount XExpression
e) =
  String -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 ()
forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
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 ()
forall annot. Expr annot -> annot -> Expr annot
Paren (Op () -> Expr () -> () -> Expr ()
forall annot. Op annot -> Expr annot -> annot -> Expr annot
UnaryOp Op ()
o' Expr ()
e' ()) ()
xExpressionToPyExpr ShowS
_ (ParamRef String
n) = String -> Expr ()
mkName 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 (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 (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 (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 ()
mkInt ([Int] -> Int
forall a. [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 (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
<= (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Expr () -> Integer
forall annot. Expr annot -> Integer
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 (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 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)

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

-- 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) =
        let cmpVal :: Expr ()
cmpVal = ShowS -> XExpression -> Expr ()
xExpressionToPyExpr ShowS
forall a. a -> a
id XExpression
bcCmp
            equality :: Expr ()
equality = Op () -> Expr () -> Expr () -> () -> Expr ()
forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (() -> Op ()
forall annot. annot -> Op annot
P.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
bcCmp
            equality :: Expr ()
equality = Op () -> Expr () -> Expr () -> () -> Expr ()
forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (() -> Op ()
forall annot. annot -> Op annot
P.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 ()
pyNone (Maybe (Expr ()) -> Expr ()) -> Maybe (Expr ()) -> Expr ()
forall a b. (a -> b) -> a -> b
$ (XExpression -> Expr ()) -> Maybe XExpression -> Maybe (Expr ())
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
c -> String -> Expr ()
mkName String
c
      list :: Expr ()
list = String -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 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 doc and fd?
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
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
forall a. a -> a
id 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') =
        let cmpVal :: Expr ()
cmpVal = ShowS -> XExpression -> Expr ()
xExpressionToPyExpr ShowS
forall a. a -> a
id XExpression
bcCmp
            equality :: Expr ()
equality = Op () -> Expr () -> Expr () -> () -> Expr ()
forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (() -> Op ()
forall annot. annot -> Op annot
P.BinaryAnd ()) Expr ()
cmp Expr ()
cmpVal ()
        in (Expr ()
equality, [GenStructElem Type]
elems')
structElemToPyPack String
_ 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
_ String
typNam ->
         let cond :: Expr ()
cond = String -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"hasattr" [String -> Argument ()
mkArg String
name, Expr () -> () -> Argument ()
forall annot. Expr annot -> annot -> Argument annot
ArgExpr (String -> Expr ()
mkStr String
"pack") ()]
             trueB :: Expr ()
trueB = String -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".pack") [Argument ()]
noArgs
             synthetic :: Expr ()
synthetic = String -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (String
typNam String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".synthetic") [String -> Argument ()
mkArg (String
"*" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name)]
             falseB :: Expr ()
falseB = Expr () -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (Expr () -> String -> Expr ()
forall a. PseudoExpr a => a -> String -> Expr ()
mkDot Expr ()
synthetic String
"pack") [Argument ()]
noArgs
         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 ()
forall annot.
Expr annot -> Expr annot -> Expr annot -> annot -> Expr annot
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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 () -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (Expr () -> String -> Expr ()
forall a. PseudoExpr a => a -> String -> Expr ()
mkDot Expr ()
e String
"pack") [Argument ()]
noArgs))
                                    )]

-- 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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"six.BytesIO" [Argument ()]
noArgs)]

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
      ([(Maybe String, String)]
toPack, [[(String,
   Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
stmts) = [Either
   (Maybe String, String)
   [(String,
     Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
-> ([(Maybe String, String)],
    [[(String,
       Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either
    (Maybe String, String)
    [(String,
      Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
 -> ([(Maybe String, String)],
     [[(String,
        Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]))
-> [Either
      (Maybe String, String)
      [(String,
        Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
-> ([(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
      ([String]
args, [String]
keys) = let ([Maybe String]
as, [String]
ks) = [(Maybe String, String)] -> ([Maybe String], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Maybe String, String)]
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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.write" [String -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 (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 ()
forall annot. Expr annot -> annot -> Statement annot
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 ()
forall annot.
[(Expr annot, Suite annot)]
-> Suite annot -> annot -> Statement annot
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 ()) -> () -> Expr () -> Statement ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr () -> () -> Statement ()
forall annot. Expr annot -> annot -> Statement annot
StmtExpr () (Expr () -> Statement ())
-> ([Expr ()] -> Expr ()) -> [Expr ()] -> Statement ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 = String -> Expr () -> Statement ()
forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign String
n (Expr () -> Statement ()) -> Expr () -> Statement ()
forall a b. (a -> b) -> a -> b
$ Expr () -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (String -> String -> Expr ()
forall a. PseudoExpr a => a -> String -> Expr ()
mkDot String
toPop String
"pop") [Int -> Expr ()
mkInt Int
0]

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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"struct.pack" [String -> Expr ()
mkStr String
"=B", Int -> Expr ()
mkInt Int
i]
                              write :: Expr ()
write = String -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.write" [Expr ()
packOpcode]
                          in (String
rest, [Expr () -> () -> Statement ()
forall annot. Expr annot -> annot -> Statement annot
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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"len" [String -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.getvalue" [Argument ()]
noArgs]
            test :: Expr ()
test = (Op () -> Expr () -> Expr () -> () -> Expr ()
forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (() -> Op ()
forall annot. annot -> Op annot
LessThan ()) Expr ()
bufLen (Int -> Expr ()
mkInt Int
len)) ()
            bufWriteLen :: Expr ()
bufWriteLen = Expr () -> () -> Expr ()
forall annot. Expr annot -> annot -> Expr annot
Paren (Op () -> Expr () -> Expr () -> () -> Expr ()
forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (() -> Op ()
forall annot. annot -> Op annot
Minus ()) (Int -> Expr ()
mkInt Int
32) Expr ()
bufLen ()) ()
            extra :: Expr ()
extra = String -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"struct.pack" [String -> Expr () -> Expr ()
repeatStr String
"x" Expr ()
bufWriteLen]
            writeExtra :: Suite ()
writeExtra = [Expr () -> () -> Statement ()
forall annot. Expr annot -> annot -> Statement annot
StmtExpr (String -> [Expr ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.write" [Expr ()
extra]) ()]
        Suite () -> [Suite ()]
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 -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.getvalue" [Argument ()]
noArgs]
  in String -> [Parameter ()] -> Suite () -> Statement ()
mkMethod String
"pack" ([String] -> [Parameter ()]
mkParams [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 ()
forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (() -> Op ()
forall annot. annot -> Op annot
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 :: [String]
stNames = StructUnpackState -> [String]
stNames StructUnpackState
st [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
name
                 , stPacks :: String
stPacks = String
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 :: Bool
stNeedsPad = Bool
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 (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 (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 ()
forall b. PseudoArgument b => b -> 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 (), Suite ())
x -> [(Expr (), Suite ())] -> Suite () -> () -> Statement ()
forall annot.
[(Expr annot, Suite annot)]
-> Suite annot -> annot -> Statement annot
Conditional [(Expr (), Suite ())
x] [] ()) ([(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 (m :: * -> *) a. Monad m => a -> m a
return ([String]
args, Suite ()
assign, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
size)

      typePad :: b -> Statement ()
typePad b
e = Expr () -> () -> Statement ()
forall annot. Expr annot -> annot -> Statement annot
StmtExpr (String -> [b] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"unpacker.pad" [b
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 :: [Parameter ()]
args = [String] -> [Parameter ()]
mkParams ([String] -> [Parameter ()]) -> [String] -> [Parameter ()]
forall a b. (a -> b) -> a -> b
$ 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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> 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 -> [Parameter ()] -> Suite () -> Statement ()
mkMethod String
"synthetic" [Parameter ()]
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]
      classmethod :: Decorator ()
classmethod = DottedName () -> [Argument ()] -> () -> Decorator ()
forall annot.
DottedName annot -> [Argument annot] -> annot -> Decorator annot
Decorator [String -> Ident ()
ident String
"classmethod"] [Argument ()]
noArgs ()
  if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
names then [] else [[Decorator ()] -> Statement () -> () -> Statement ()
forall annot.
[Decorator annot] -> Statement annot -> annot -> Statement annot
Decorated [Decorator ()
classmethod] Statement ()
synthetic ()]
    where
      getName :: GenStructElem Type -> Maybe String
      getName :: GenStructElem Type -> Maybe String
getName (Pad 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

      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 (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 (m :: * -> *) a. Monad m => a -> m a
return BindingPart
Noop
processXDecl String
_ (XImport String
n) =
  BindingPart -> StateT TypeInfoMap Identity BindingPart
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 (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 ()
mkInt Int
theLen
        Statement () -> Maybe (Statement ())
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 (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 -> Suite () -> Suite () -> Statement ()
mkXClass String
n String
"xcffib.Struct" 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
_ [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
  BindingPart -> StateT TypeInfoMap Identity BindingPart
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 -> Suite () -> Suite () -> Statement ()
mkXClass String
cname String
"xcffib.Event" 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 (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 -> Suite () -> Suite () -> Statement ()
mkXClass String
cname String
"xcffib.Error" 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 -> Suite () -> Suite () -> Statement ()
mkXClass String
replyName String
"xcffib.Reply" 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 (m :: * -> *) a. Monad m => a -> m a
return [Statement ()
theReply, Statement ()
cookie]

      hasReply :: [Argument ()]
hasReply = if Suite () -> 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 [Expr () -> () -> Argument ()
forall annot. Expr annot -> annot -> Argument annot
ArgExpr (String -> Expr ()
mkName String
cookieName) ()]
                 else []
      isChecked :: Expr ()
isChecked = Bool -> Expr ()
pyTruth (Bool -> Expr ()) -> Bool -> Expr ()
forall a b. (a -> b) -> a -> b
$ Maybe (GenXReply Type) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (GenXReply Type)
reply
      argChecked :: Argument ()
argChecked = Ident () -> Expr () -> () -> Argument ()
forall annot. Ident annot -> Expr annot -> annot -> Argument annot
ArgKeyword (String -> Ident ()
ident String
"is_checked") (String -> Expr ()
mkName String
"is_checked") ()
      checkedParam :: Parameter ()
checkedParam = Ident ()
-> Maybe (Expr ()) -> Maybe (Expr ()) -> () -> Parameter ()
forall annot.
Ident annot
-> Maybe (Expr annot)
-> Maybe (Expr annot)
-> annot
-> Parameter annot
Param (String -> Ident ()
ident String
"is_checked") Maybe (Expr ())
forall a. Maybe a
Nothing (Expr () -> Maybe (Expr ())
forall a. a -> Maybe a
Just Expr ()
isChecked) ()
      allArgs :: [Parameter ()]
allArgs = ([String] -> [Parameter ()]
mkParams ([String] -> [Parameter ()]) -> [String] -> [Parameter ()]
forall a b. (a -> b) -> a -> b
$ String
"self" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args) [Parameter ()] -> [Parameter ()] -> [Parameter ()]
forall a. [a] -> [a] -> [a]
++ [Parameter ()
checkedParam]
      mkArg' :: Expr () -> Argument ()
mkArg' = (Expr () -> () -> Argument ()) -> () -> Expr () -> Argument ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr () -> () -> Argument ()
forall annot. Expr annot -> annot -> Argument annot
ArgExpr ()
      ret :: Statement ()
ret = Expr () -> Statement ()
mkReturn (Expr () -> Statement ()) -> Expr () -> Statement ()
forall a b. (a -> b) -> a -> b
$ String -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"self.send_request" (((Expr () -> Argument ()) -> [Expr ()] -> [Argument ()]
forall a b. (a -> b) -> [a] -> [b]
map Expr () -> Argument ()
mkArg' [ Int -> Expr ()
mkInt Int
opcode
                                                               , String -> Expr ()
mkName String
"buf"
                                                               ])
                                                               [Argument ()] -> [Argument ()] -> [Argument ()]
forall a. [a] -> [a] -> [a]
++ [Argument ()]
hasReply
                                                               [Argument ()] -> [Argument ()] -> [Argument ()]
forall a. [a] -> [a] -> [a]
++ [Argument ()
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 -> [Parameter ()] -> Suite () -> Statement ()
mkMethod String
name [Parameter ()]
allArgs Suite ()
requestBody
  BindingPart -> StateT TypeInfoMap Identity BindingPart
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
      ([(Maybe String, String)]
fields, [(String,
  Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
  Maybe Int)]
listInfo) = [Either
   (Maybe String, String)
   (String,
    Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
    Maybe Int)]
-> ([(Maybe String, String)],
    [(String,
      Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
      Maybe Int)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either
    (Maybe String, String)
    (String,
     Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
     Maybe Int)]
 -> ([(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)]
-> ([(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
$ ((Maybe String, String) -> Suite ())
-> [(Maybe String, String)] -> [Suite ()]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe String, String) -> Suite ()
mkUnionUnpack [(Maybe String, String)]
fields
      ([String]
names, [Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])]]
listOrSwitches, [Maybe Int]
_) = [(String,
  Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
  Maybe Int)]
-> ([String],
    [Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])]],
    [Maybe Int])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(String,
  Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
  Maybe Int)]
listInfo
      ([Expr ()]
exprs, [Expr ()]
_) = [(Expr (), Expr ())] -> ([Expr ()], [Expr ()])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Expr (), Expr ())] -> ([Expr ()], [Expr ()]))
-> [(Expr (), Expr ())] -> ([Expr ()], [Expr ()])
forall a b. (a -> b) -> a -> b
$ (Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])]
 -> (Expr (), Expr ()))
-> [Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])]]
-> [(Expr (), Expr ())]
forall a b. (a -> b) -> [a] -> [b]
map Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])]
-> (Expr (), Expr ())
forall a b. Either a b -> a
fromLeft' [Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])]]
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
      initMethod :: Suite ()
initMethod = Suite ()
lists 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. [a] -> a
head [GenStructElem Type]
membs] Maybe Int
forall a. Maybe a
Nothing
      decl :: Suite ()
decl = [String -> String -> Suite () -> Suite () -> Statement ()
mkXClass String
name String
"xcffib.Union" 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 (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 -> [Argument ()] -> Expr ()
forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"unpacker.copy" [Argument ()]
noArgs
    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

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 (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 (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 -> Suite () -> Suite () -> Statement ()
mkXClass String
name String
"xcffib.Buffer" [] []]

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 (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 ()
mkInt 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 b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"xcffib.ExtensionKey" [String -> Expr ()
mkStr String
name]
  Statement () -> Maybe (Statement ())
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