{-
 - Copyright 2014 Tycho Andersen
 -
 - Licensed under the Apache License, Version 2.0 (the "License");
 - you may not use this file except in compliance with the License.
 - You may obtain a copy of the License at
 -
 -   http://www.apache.org/licenses/LICENSE-2.0
 -
 - Unless required by applicable law or agreed to in writing, software
 - distributed under the License is distributed on an "AS IS" BASIS,
 - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 - See the License for the specific language governing permissions and
 - limitations under the License.
 -}
{-# LANGUAGE ViewPatterns #-}
module Data.XCB.Python.Parse (
  parseXHeaders,
  xform,
  renderPy,
  calcsize
  ) where

import Control.Applicative hiding (getConst)
import Control.Monad.State.Strict

import Data.Attoparsec.ByteString.Char8
import Data.Bits
import qualified Data.ByteString.Char8 as BS
import Data.Either.Combinators as EC
import Data.List
import qualified Data.Map as M
import Data.Tree
import Data.Maybe
import Data.XCB.FromXML
import Data.XCB.Types as X
import Data.XCB.Python.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
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
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
Ord, Int -> TypeInfo -> ShowS
[TypeInfo] -> ShowS
TypeInfo -> String
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
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 = 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 forall a. a -> [a] -> [a]
: Suite ()
defs, Suite ()
decl forall a. [a] -> [a] -> [a]
++ Suite ()
decls)
    collectR (Declaration Suite ()
decl) (Suite ()
defs, Suite ()
decls) = (Suite ()
defs, Suite ()
decl 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 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 = ((forall a. [a] -> [[a]] -> [a]
intercalate String
"\n") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> String
prettyText Suite ()
s) 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 = forall a b. (a -> b) -> [a] -> [b]
map Tree XHeader -> (String, Suite ())
buildPython forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XHeader] -> Forest 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' = (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM XHeader -> State TypeInfoMap (String, Suite ())
processXHeader forall a b. (a -> b) -> a -> b
$ forall a. Tree a -> [a]
postOrder Tree XHeader
forest)
          results :: [(String, Suite ())]
results = forall s a. State s a -> s -> a
evalState StateT TypeInfoMap Identity [(String, Suite ())]
forest' TypeInfoMap
baseTypeInfo
      in forall a. [a] -> a
last [(String, Suite ())]
results
    processXHeader :: XHeader
                   -> State TypeInfoMap (String, Suite ())
    processXHeader :: XHeader -> State TypeInfoMap (String, Suite ())
processXHeader XHeader
header = do
      let imports :: Suite ()
imports = [String -> Statement ()
mkImport String
"xcffib", String -> Statement ()
mkImport String
"struct", String -> Statement ()
mkImport String
"io"]
          version :: Suite ()
version = XHeader -> Suite ()
mkVersion XHeader
header
          key :: Suite ()
key = forall a. Maybe a -> [a]
maybeToList 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 = forall typ. GenXHeader typ -> String
xheader_header XHeader
header
          add :: Suite ()
add = [XHeader -> Statement ()
mkAddExt XHeader
header]
      [BindingPart]
parts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> XDecl -> State TypeInfoMap BindingPart
processXDecl String
name) forall a b. (a -> b) -> a -> b
$ 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 forall (t :: * -> *) a. Foldable t => t a -> Int
length Suite ()
requests forall a. Ord a => a -> a -> Bool
> Int
0
                then [String -> String -> Suite () -> Statement ()
mkClass (String
name forall a. [a] -> [a] -> [a]
++ String
"Extension") String
"xcffib.Extension" Suite ()
requests]
                else []
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (String
name, 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] -> Forest XHeader
dependencyOrder [XHeader]
headers = forall b a. (b -> (a, [b])) -> [b] -> [Tree a]
unfoldForest String -> (XHeader, [String])
unfold forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall typ. GenXHeader typ -> String
xheader_header [XHeader]
headers
      where
        headerM :: Map String XHeader
headerM = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\XHeader
h -> (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 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 = forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map XDecl -> Maybe String
matchImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall typ. GenXHeader typ -> [GenXDecl typ]
xheader_decls
        matchImport :: XDecl -> Maybe String
        matchImport :: XDecl -> Maybe String
matchImport (XImport String
n) = forall a. a -> Maybe a
Just String
n
        matchImport XDecl
_ = forall a. Maybe a
Nothing
    postOrder :: Tree a -> [a]
    postOrder :: forall a. Tree a -> [a]
postOrder (Node a
e [Tree a]
cs) = (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Tree a -> [a]
postOrder [Tree a]
cs) forall a. [a] -> [a] -> [a]
++ [a
e]


mkAddExt :: XHeader -> Statement ()
mkAddExt :: XHeader -> Statement ()
mkAddExt (forall typ. GenXHeader typ -> String
xheader_header -> String
"xproto") =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall annot. Expr annot -> annot -> Statement annot
StmtExpr () forall a b. (a -> b) -> a -> b
$ 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 = forall typ. GenXHeader typ -> String
xheader_header XHeader
header
  in forall a b c. (a -> b -> c) -> b -> a -> c
flip forall annot. Expr annot -> annot -> Statement annot
StmtExpr () forall a b. (a -> b) -> a -> b
$ 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 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 = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList 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 = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
i 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 = 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 = 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 forall a. Parser a -> ByteString -> Either String a
parseOnly Parser ByteString [(Maybe Int, Char)]
lang (String -> ByteString
BS.pack String
s) of
                       Left String
err -> forall a. HasCallStack => String -> a
error (String
"can't calcsize " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
err)
                       Right [(Maybe Int, Char)]
xs -> [(Maybe Int, Char)]
xs

    lang :: Parser ByteString [(Maybe Int, Char)]
lang = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Char -> Bool) -> Parser Char
satisfy forall a b. (a -> b) -> a -> b
$ String -> Char -> Bool
inClass forall a b. (a -> b) -> a -> b
$ 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 = forall annot. annot -> Op annot
P.Plus ()
xBinopToPyOp Binop
X.Sub = forall annot. annot -> Op annot
P.Minus ()
xBinopToPyOp Binop
X.Mult = forall annot. annot -> Op annot
P.Multiply ()
xBinopToPyOp Binop
X.Div = forall annot. annot -> Op annot
P.FloorDivide ()
xBinopToPyOp Binop
X.And = forall annot. annot -> Op annot
P.BinaryAnd ()
xBinopToPyOp Binop
X.RShift = forall annot. annot -> Op annot
P.ShiftRight ()

xUnopToPyOp :: X.Unop -> P.Op ()
xUnopToPyOp :: Unop -> Op ()
xUnopToPyOp Unop
X.Complement = 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) =
  forall annot. Expr annot -> annot -> Expr annot
Paren (ShowS -> XExpression -> Expr ()
xExpressionToPyExpr ShowS
acc (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) = forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (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 forall a b. (a -> b) -> a -> b
$ ShowS
acc String
n
xExpressionToPyExpr ShowS
_ (EnumRef (UnQualType String
enum) String
n) = String -> Expr ()
mkName forall a b. (a -> b) -> a -> b
$ String
enum forall a. [a] -> [a] -> [a]
++ String
"." 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
_) = forall a. HasCallStack => String -> a
error String
"Qualified type, unknown behavior"
xExpressionToPyExpr ShowS
acc (PopCount XExpression
e) =
  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) = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"sum" [String -> Expr ()
mkName 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 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 forall annot. Expr annot -> annot -> Expr annot
Paren (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) = forall a. a -> Maybe a
Just Int
i
getConst (Bit Int
i) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Binop
o of
             Binop
X.Add -> Int
c1 forall a. Num a => a -> a -> a
+ Int
c2
             Binop
X.Sub -> Int
c1 forall a. Num a => a -> a -> a
- Int
c2
             Binop
X.Mult -> Int
c1 forall a. Num a => a -> a -> a
* Int
c2
             Binop
X.Div -> Int
c1 forall a. Integral a => a -> a -> a
`quot` Int
c2
             Binop
X.And -> Int
c1 forall a. Bits a => a -> a -> a
.&. Int
c2
             Binop
X.RShift -> Int
c1 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
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Unop
o of
             Unop
X.Complement -> forall a. Bits a => a -> a
complement Int
c
getConst (PopCount XExpression
e) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Bits a => a -> Int
popCount forall a b. (a -> b) -> a -> b
$ XExpression -> Maybe Int
getConst XExpression
e
getConst XExpression
_ = forall a. Maybe a
Nothing

xEnumElemsToPyEnum :: (String -> String) -> [XEnumElem] -> [(String, Expr ())]
xEnumElemsToPyEnum :: ShowS -> [XEnumElem] -> [(String, Expr ())]
xEnumElemsToPyEnum ShowS
accessor [XEnumElem]
membs = forall a. [a] -> [a]
reverse 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' = forall a. a -> Maybe a -> a
fromMaybe (Int -> Expr ()
mkInt (forall a. [a] -> a
head [Int]
is)) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap XExpression -> Expr ()
exprConv Maybe XExpression
expr
          is' :: [Int]
is' = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
<= (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall annot. Expr annot -> Integer
int_value Expr ()
expr'))) [Int]
is
          acc' :: [(String, Expr ())]
acc' = (String
name, Expr ()
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 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 forall a. Eq a => a -> a -> Bool
== String
prefix then String
result forall a. [a] -> [a] -> [a]
++ (Char
c forall a. a -> [a] -> [a]
: String
cs) else String
result forall a. [a] -> [a] -> [a]
++ String
cs
addStructData String
prefix String
s = (String -> Char -> String
maybePrintChar String
prefix Char
'x') forall a. [a] -> [a] -> [a]
++ String
s

maybePrintChar :: String -> Char -> String
maybePrintChar :: String -> Char -> String
maybePrintChar String
s Char
c | String
"%c" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s = 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 = (forall a. Show a => a -> String
show Int
i) 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) = forall a b. a -> Either a b
Left (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)]
_) = forall a b. a -> Either a b
Left (forall a. Maybe a
Nothing, String
"")
-- XXX: What does fd mean? we should implement it correctly
structElemToPyUnpack Expr ()
_ String
_ TypeInfoMap
_ (Fd String
_) = forall a b. a -> Either a b
Left (forall a. Maybe a
Nothing, String
"")
structElemToPyUnpack Expr ()
_ String
_ TypeInfoMap
_ (Length Type
_ XExpression
_) = forall a b. a -> Either a b
Left (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 (forall a. [a] -> [a] -> [a]
(++) String
"self.") XExpression
expr
      switch :: [(Expr (), [GenStructElem Type])]
switch = forall a b. (a -> b) -> [a] -> [b]
map (Expr () -> GenBitCase Type -> (Expr (), [GenStructElem Type])
mkSwitch Expr ()
cmp) [GenBitCase Type]
bitcases
  in forall a b. b -> Either a b
Right (String
name, forall a b. b -> Either a b
Right [(Expr (), [GenStructElem Type])]
switch, 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 forall a. a -> a
id XExpression
bcCmp
            equality :: Expr ()
equality = forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (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 forall a. a -> a
id XExpression
bcCmp
            equality :: Expr ()
equality = forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (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 = (forall a. [a] -> [a] -> [a]
(++) String
"self.")
      len' :: Expr ()
len' = forall a. a -> Maybe a -> a
fromMaybe Expr ()
pyNone forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS -> XExpression -> Expr ()
xExpressionToPyExpr ShowS
attr) Maybe XExpression
len
      cons :: Expr ()
cons = case TypeInfoMap
m 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 forall a. Eq a => a -> a -> Bool
/= String
tExt -> String -> Expr ()
mkName forall a b. (a -> b) -> a -> b
$ String
tExt forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
c
               CompositeType String
_ String
c -> String -> Expr ()
mkName String
c
      list :: Expr ()
list = 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 forall a b. b -> Either a b
Right (String
n, 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 forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
    BaseType String
c -> forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just String
n, String
c)
    CompositeType String
tExt String
c ->
      let c' :: String
c' = if String
tExt forall a. Eq a => a -> a -> Bool
== String
ext then String
c else String
tExt forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
c
          field :: Expr ()
field = 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 forall a b. b -> Either a b
Right (String
n, forall a b. a -> Either a b
Left (Expr ()
field, String -> Expr ()
mkName String
c'), forall a. Maybe a
Nothing)
structElemToPyUnpack Expr ()
_ String
_ TypeInfoMap
_ (ExprField String
_ Type
_ XExpression
_) = forall a. HasCallStack => String -> a
error String
"Only valid for requests"
structElemToPyUnpack Expr ()
_ String
_ TypeInfoMap
_ (ValueParam Type
_ String
_ Maybe Int
_ String
_) = 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) = forall a b. a -> Either a b
Left (forall a. Maybe a
Nothing, Int -> String
mkPad Int
i)
-- TODO: implement these?
structElemToPyPack String
_ TypeInfoMap
_ ShowS
_ (Doc Maybe String
_ Map String String
_ [(String, String)]
_) = forall a b. a -> Either a b
Left (forall a. Maybe a
Nothing, String
"")
structElemToPyPack String
_ TypeInfoMap
_ ShowS
_ (Fd String
_) = forall a b. a -> Either a b
Left (forall a. Maybe a
Nothing, String
"")
structElemToPyPack String
_ TypeInfoMap
_ ShowS
_ (Length Type
_ XExpression
_) = forall a b. a -> Either a b
Left (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 forall a. a -> a
id XExpression
expr
      elems :: [(Expr (), [GenStructElem Type])]
elems = forall a b. (a -> b) -> [a] -> [b]
map (Expr () -> GenBitCase Type -> (Expr (), [GenStructElem Type])
mkSwitch Expr ()
cmp) [GenBitCase Type]
bitcases
  in forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [(String
name, 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 forall a. a -> a
id XExpression
bcCmp
            equality :: Expr ()
equality = forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (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 forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
       BaseType String
c -> forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just String
name, String
c)
       CompositeType String
_ String
typNam ->
         let cond :: Expr ()
cond = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"hasattr" [String -> Argument ()
mkArg String
name, forall annot. Expr annot -> annot -> Argument annot
ArgExpr (String -> Expr ()
mkStr String
"pack") ()]
             trueB :: Expr ()
trueB = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (String
name forall a. [a] -> [a] -> [a]
++ String
".pack") [Argument ()]
noArgs
             synthetic :: Expr ()
synthetic = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (String
typNam forall a. [a] -> [a] -> [a]
++ String
".synthetic") [String -> Argument ()
mkArg (String
"*" forall a. [a] -> [a] -> [a]
++ String
name)]
             falseB :: Expr ()
falseB = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (forall a. PseudoExpr a => a -> String -> Expr ()
mkDot Expr ()
synthetic String
"pack") [Argument ()]
noArgs
         in forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [(String
name
                    , forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (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 forall a. Maybe a -> Bool
isNothing Maybe XExpression
expr then [(String
name forall a. [a] -> [a] -> [a]
++ String
"_len", forall a b. a -> Either a b
Left forall a. Maybe a
Nothing)] else []
      list :: [(String, Either (Maybe (Expr ())) b)]
list = case TypeInfoMap
m forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
        BaseType String
c -> [(String
name
                      , forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"xcffib.pack_list" [ String -> Expr ()
mkName 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 forall a. Eq a => a -> a -> Bool
== String
ext then String
c else (String
tExt forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
c)
          in [(String
name
             , forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"xcffib.pack_list" ([ String -> Expr ()
mkName forall a b. (a -> b) -> a -> b
$ String
name
                                                      , String -> Expr ()
mkName String
c'
                                                      ])))
             )]
  in forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall {a} {b}. [(String, Either (Maybe a) b)]
list_len forall a. [a] -> [a] -> [a]
++ 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 forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
       BaseType String
c -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [(String
name'
                             , forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"struct.pack" [ String -> Expr ()
mkStr (Char
'=' forall a. a -> [a] -> [a]
: String
c)
                                                                , Expr ()
e
                                                                ]))
                             )]
       CompositeType String
_ String
_ -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [(String
name'
                                    , forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (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 forall k a. Ord k => Map k a -> k -> a
M.! Type
typ of
    BaseType String
c ->
      let mask' :: Expr ()
mask' = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"struct.pack" [String -> Expr ()
mkStr (Char
'=' forall a. a -> [a] -> [a]
: String
c), String -> Expr ()
mkName forall a b. (a -> b) -> a -> b
$ ShowS
accessor String
mask]
          list' :: Expr ()
list' = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"xcffib.pack_list" [ String -> Expr ()
mkName forall a b. (a -> b) -> a -> b
$ ShowS
accessor String
list
                                            , String -> Expr ()
mkStr String
"I"
                                            ]
      in forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [(String
mask, forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just Expr ()
mask')), (String
list, forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just Expr ()
list'))]
    CompositeType String
_ String
_ -> forall a. HasCallStack => String -> a
error (
      String
"ValueParams other than CARD{16,32} not allowed.")

buf :: Suite ()
buf :: Suite ()
buf = [forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign String
"buf" (forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"io.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
      ([Either
   (Maybe String, String)
   [(String,
     Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
toPack, [Either
   (Maybe String, String)
   [(String,
     Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
stmts) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span forall a b. Either a b -> Bool
EC.isLeft forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map GenStructElem Type
-> Either
     (Maybe String, String)
     [(String,
       Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]
packF [GenStructElem Type]
membs
      stmts' :: [[(String,
   Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
stmts' = forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {b}.
(Maybe String, String) -> [(String, Either (Maybe (Expr ())) b)]
mkBasePack forall a. a -> a
id) [Either
   (Maybe String, String)
   [(String,
     Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
stmts
      ([String]
args, [String]
keys) = let ([Maybe String]
as, [String]
ks) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. Either a b -> a
EC.fromLeft' [Either
   (Maybe String, String)
   [(String,
     Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
toPack) in (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) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem [String]
args forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(String,
   Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])])]]
stmts')
      listWrites :: Suite ()
listWrites = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String
-> Either (Maybe (Expr ())) [(Expr (), [GenStructElem Type])]
-> Suite ()
mkWrites) forall a b. (a -> b) -> a -> b
$ 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 forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
notOdd [String]
listNames
                     (String, String)
_ -> [String]
listNames
      packStr :: String
packStr = String -> ShowS
addStructData String
prefix forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"" [String]
keys
      write :: Expr ()
write = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.write" [forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"struct.pack"
                                         (String -> Expr ()
mkStr (Char
'=' forall a. a -> [a] -> [a]
: String
packStr) forall a. a -> [a] -> [a]
: (forall a b. (a -> b) -> [a] -> [b]
map String -> Expr ()
mkName [String]
args))]
      writeStmt :: Suite ()
writeStmt = if forall (t :: * -> *) a. Foldable t => t a -> Int
length String
packStr forall a. Ord a => a -> a -> Bool
> Int
0 then [forall annot. Expr annot -> annot -> Statement annot
StmtExpr Expr ()
write ()] else []
  in ([String]
args forall a. [a] -> [a] -> [a]
++ [String]
listNames', Suite ()
writeStmt 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) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Expr (), [GenStructElem Type])]
condList
            ([[String]]
names, [Suite ()]
stmts) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> [a] -> [b]
map (\(Expr ()
x, [String]
y, Suite ()
z) -> forall annot.
[(Expr annot, Suite annot)]
-> Suite annot -> annot -> Statement annot
Conditional [(Expr ()
x, forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Statement ()
mkPop String
valueList) [String]
y forall a. [a] -> [a] -> [a]
++ Suite ()
z)] [] ()) forall a b. (a -> b) -> a -> b
$ 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' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall annot. Expr annot -> annot -> Statement annot
StmtExpr () forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.write" forall a b. (a -> b) -> a -> b
$ (forall a. a -> [a] -> [a]
: []) Expr ()
expr'

      mkPop :: String
            -> String
            -> Statement ()
      mkPop :: String -> String -> Statement ()
mkPop String
toPop String
n = forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign String
n forall a b. (a -> b) -> a -> b
$ forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (forall a. PseudoExpr a => a -> String -> Expr ()
mkDot String
toPop String
"pop") [Int -> Expr ()
mkInt Int
0]

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

mkPackMethod :: String
             -> String
             -> TypeInfoMap
             -> Maybe (String, Int)
             -> [GenStructElem Type]
             -> Maybe Int
             -> Statement ()
mkPackMethod :: String
-> String
-> TypeInfoMap
-> Maybe (String, Int)
-> [GenStructElem Type]
-> Maybe Int
-> Statement ()
mkPackMethod String
ext String
name TypeInfoMap
m Maybe (String, Int)
prefixAndOp [GenStructElem Type]
structElems Maybe Int
minLen =
  let accessor :: ShowS
accessor = (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 = 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 = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.write" [Expr ()
packOpcode]
                          in (String
rest, [forall annot. Expr annot -> annot -> Statement annot
StmtExpr Expr ()
write ()])
                        Just (String
rest, Int
_) -> forall a. HasCallStack => String -> a
error (String
"internal API error: " forall a. [a] -> [a] -> [a]
++ 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ do
        Int
len <- forall a. Maybe a -> [a]
maybeToList Maybe Int
minLen
        let bufLen :: Expr ()
bufLen = String -> Expr ()
mkName String
"buf_len"
            bufLenAssign :: Statement ()
bufLenAssign = forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign Expr ()
bufLen forall a b. (a -> b) -> a -> b
$ forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"len" [forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.getvalue" [Argument ()]
noArgs]
            test :: Expr ()
test = (forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (forall annot. annot -> Op annot
LessThan ()) Expr ()
bufLen (Int -> Expr ()
mkInt Int
len)) ()
            bufWriteLen :: Expr ()
bufWriteLen = forall annot. Expr annot -> annot -> Expr annot
Paren (forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (forall annot. annot -> Op annot
Minus ()) (Int -> Expr ()
mkInt Int
32) Expr ()
bufLen ()) ()
            extra :: Expr ()
extra = 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 = [forall annot. Expr annot -> annot -> Statement annot
StmtExpr (forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"buf.write" [Expr ()
extra]) ()]
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Statement ()
bufLenAssign, Expr () -> Suite () -> Statement ()
mkIf Expr ()
test Suite ()
writeExtra]
      ret :: Suite ()
ret = [Expr () -> Statement ()
mkReturn forall a b. (a -> b) -> a -> b
$ 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"]) forall a b. (a -> b) -> a -> b
$ Suite ()
buf forall a. [a] -> [a] -> [a]
++ Suite ()
op forall a. [a] -> [a] -> [a]
++ Suite ()
packStmts forall a. [a] -> [a] -> [a]
++ Suite ()
extend 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 = 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) = 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 = [forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign String
"base" forall a b. (a -> b) -> a -> b
$ String -> Expr ()
mkName String
"unpacker.offset"]
      bufsize :: Suite ()
bufsize =
        let rhs :: Expr ()
rhs = forall annot.
Op annot -> Expr annot -> Expr annot -> annot -> Expr annot
BinaryOp (forall annot. annot -> Op annot
Minus ()) (String -> Expr ()
mkName String
"unpacker.offset") (String -> Expr ()
mkName String
"base") ()
        in [forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign (String -> Expr ()
mkAttr String
"bufsize") Expr ()
rhs]
      statements :: Suite ()
statements = Suite ()
base forall a. [a] -> [a] -> [a]
++ Suite ()
unpackStmts 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 <- forall s (m :: * -> *). MonadState s m => m s
get
        let packs :: String
packs = if String
"%c" 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) forall a. [a] -> [a] -> [a]
++ String
pack
        forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ StructUnpackState
st { stNames :: [String]
stNames = StructUnpackState -> [String]
stNames StructUnpackState
st forall a. [a] -> [a] -> [a]
++ 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 <- forall s (m :: * -> *). MonadState s m => m s
get
        forall s (m :: * -> *). MonadState s m => s -> m ()
put 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
                          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
before forall a. Num a => a -> a -> a
+ Int
rest forall a. Num a => a -> a -> a
+ Int
thisSz'
        forall (m :: * -> *) a. Monad m => a -> m a
return ( [String]
packNames forall a. [a] -> [a] -> [a]
++ [String
thisName] forall a. [a] -> [a] -> [a]
++ [String]
restNames
               , Suite ()
packStmt forall a. [a] -> [a] -> [a]
++ Suite ()
thisStmts 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 [forall {b}. PseudoArgument b => b -> Statement ()
typePad Expr ()
cons]
                        else []
              in Suite ()
pad forall a. [a] -> [a] -> [a]
++ [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) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Expr (), [GenStructElem Type])]
switchList
                  stmts :: [Suite ()]
stmts = forall a b. (a -> b) -> [a] -> [b]
map (StructUnpackState -> [GenStructElem Type] -> Suite ()
mkUnpackSwitchElems StructUnpackState
st') [[GenStructElem Type]]
elems
              in forall a b. (a -> b) -> [a] -> [b]
map (\(Expr (), Suite ())
x -> forall annot.
[(Expr annot, Suite annot)]
-> Suite annot -> annot -> Statement annot
Conditional [(Expr (), Suite ())
x] [] ()) forall a b. (a -> b) -> a -> b
$ 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' = 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
_) = 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 <- forall s (m :: * -> *). MonadState s m => m s
get
        let size :: Int
size = String -> Int
calcsize String
keys
            assign :: Suite ()
assign = forall a. PseudoExpr a => a -> [String] -> String -> Suite ()
mkUnpackFrom String
"unpacker" [String]
args String
keys
        forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ Bool -> [String] -> String -> StructUnpackState
StructUnpackState Bool
needsPad [] String
""
        forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
args, Suite ()
assign, forall a. a -> Maybe a
Just Int
size)

      typePad :: b -> Statement ()
typePad b
e = forall annot. Expr annot -> annot -> Statement annot
StmtExpr (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' = 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 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 = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map GenStructElem Type -> Maybe String
getName [GenStructElem Type]
membs
      args :: [Parameter ()]
args = [String] -> [Parameter ()]
mkParams forall a b. (a -> b) -> a -> b
$ String
"cls" forall a. a -> [a] -> [a]
: [String]
names
      self :: Statement ()
self = forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign String
"self" forall a b. (a -> b) -> a -> b
$ forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall (forall a. PseudoExpr a => a -> String -> Expr ()
mkDot String
"cls" String
"__new__") [String -> Expr ()
mkName String
"cls"]
      body :: Suite ()
body = forall a b. (a -> b) -> [a] -> [b]
map String -> Statement ()
assign [String]
names
      ret :: Statement ()
ret = Expr () -> Statement ()
mkReturn forall a b. (a -> b) -> a -> b
$ String -> Expr ()
mkName String
"self"
      synthetic :: Statement ()
synthetic = String -> [Parameter ()] -> Suite () -> Statement ()
mkMethod String
"synthetic" [Parameter ()]
args forall a b. (a -> b) -> a -> b
$ (Statement ()
self forall a. a -> [a] -> [a]
: Suite ()
body) forall a. [a] -> [a] -> [a]
++ [Statement ()
ret]
      classmethod :: Decorator ()
classmethod = forall annot.
DottedName annot -> [Argument annot] -> annot -> Decorator annot
Decorator [String -> Ident ()
ident String
"classmethod"] [Argument ()]
noArgs ()
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
names then [] else [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
_) = forall a. Maybe a
Nothing
      getName (X.List String
n Type
_ Maybe XExpression
_ Maybe Type
_) = forall a. a -> Maybe a
Just String
n
      getName (SField String
n Type
_ Maybe Type
_ Maybe Type
_) = forall a. a -> Maybe a
Just String
n
      getName (ExprField String
n Type
_ XExpression
_) = forall a. a -> Maybe a
Just String
n
      getName (ValueParam Type
_ String
n Maybe Int
_ String
_) = forall a. a -> Maybe a
Just String
n
      getName (Switch String
n XExpression
_ Maybe Alignment
_ [GenBitCase Type]
_) = forall a. a -> Maybe a
Just String
n
      getName (Doc Maybe String
_ Map String String
_ [(String, String)]
_) = forall a. Maybe a
Nothing
      getName (Fd String
n) = forall a. a -> Maybe a
Just String
n
      getName (Length Type
_ XExpression
_) = forall a. Maybe a
Nothing

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

processXDecl :: String
             -> XDecl
             -> State TypeInfoMap BindingPart
processXDecl :: String -> XDecl -> State TypeInfoMap BindingPart
processXDecl String
ext (XTypeDef String
name Type
typ) =
  do forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \TypeInfoMap
m -> String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
name (TypeInfoMap
m forall k a. Ord k => Map k a -> k -> a
M.! Type
typ) TypeInfoMap
m
     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 forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
name (String -> TypeInfo
BaseType String
"I")
     forall (m :: * -> *) a. Monad m => a -> m a
return BindingPart
Noop
processXDecl String
_ (XImport String
n) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Suite () -> BindingPart
Declaration [ String -> Statement ()
mkRelImport String
n]
processXDecl String
_ (XEnum String
name [XEnumElem]
membs) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Suite () -> BindingPart
Declaration [String -> [(String, Expr ())] -> Statement ()
mkEnum String
name forall a b. (a -> b) -> a -> b
$ ShowS -> [XEnumElem] -> [(String, Expr ())]
xEnumElemsToPyEnum forall a. a -> a
id [XEnumElem]
membs]
processXDecl String
ext (XStruct String
n Maybe Alignment
_ [GenStructElem Type]
membs) = do
  TypeInfoMap
m <- 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 forall a. Maybe a
Nothing [GenStructElem Type]
membs forall a. Maybe a
Nothing
      synthetic :: Suite ()
synthetic = [GenStructElem Type] -> Suite ()
mkSyntheticMethod [GenStructElem Type]
membs
      fixedLength :: Suite ()
fixedLength = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ do
        Int
theLen <- Maybe Int
len
        let rhs :: Expr ()
rhs = Int -> Expr ()
mkInt Int
theLen
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign String
"fixed_size" Expr ()
rhs
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify 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)
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. a -> [a] -> [a]
: Suite ()
fixedLength 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 <- forall s (m :: * -> *). MonadState s m => m s
get
  let cname :: String
cname = String
name forall a. [a] -> [a] -> [a]
++ String
"Event"
      prefix :: String
prefix = if 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 (forall a. a -> Maybe a
Just (String
prefix, Int
opcode)) [GenStructElem Type]
membs (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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 <- forall s (m :: * -> *). MonadState s m => m s
get
  let cname :: String
cname = String
name 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 (forall a. a -> Maybe a
Just (String
prefix, Int
opcode)) [GenStructElem Type]
membs 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 = forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign (String
"Bad" forall a. [a] -> [a] -> [a]
++ String
name) (String -> Expr ()
mkName String
cname)
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- 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 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 forall a. a -> a
id String
prefix [GenStructElem Type]
membs
      cookieName :: String
cookieName = (String
name forall a. [a] -> [a] -> [a]
++ String
"Cookie")
      replyDecl :: Suite ()
replyDecl = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList 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 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 = forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign String
"reply_type" 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]
        forall (m :: * -> *) a. Monad m => a -> m a
return [Statement ()
theReply, Statement ()
cookie]

      hasReply :: [Argument ()]
hasReply = if forall (t :: * -> *) a. Foldable t => t a -> Int
length Suite ()
replyDecl forall a. Ord a => a -> a -> Bool
> Int
0
                 then [forall annot. Expr annot -> annot -> Argument annot
ArgExpr (String -> Expr ()
mkName String
cookieName) ()]
                 else []
      isChecked :: Expr ()
isChecked = Bool -> Expr ()
pyTruth forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isJust Maybe (GenXReply Type)
reply
      argChecked :: Argument ()
argChecked = 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 = forall annot.
Ident annot
-> Maybe (Expr annot)
-> Maybe (Expr annot)
-> annot
-> Parameter annot
Param (String -> Ident ()
ident String
"is_checked") forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Expr ()
isChecked) ()
      allArgs :: [Parameter ()]
allArgs = ([String] -> [Parameter ()]
mkParams forall a b. (a -> b) -> a -> b
$ String
"self" forall a. a -> [a] -> [a]
: (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
args)) forall a. [a] -> [a] -> [a]
++ [Parameter ()
checkedParam]
      mkArg' :: Expr () -> Argument ()
mkArg' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall annot. Expr annot -> annot -> Argument annot
ArgExpr ()
      ret :: Statement ()
ret = Expr () -> Statement ()
mkReturn forall a b. (a -> b) -> a -> b
$ forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"self.send_request" ((forall a b. (a -> b) -> [a] -> [b]
map Expr () -> Argument ()
mkArg' [ Int -> Expr ()
mkInt Int
opcode
                                                               , String -> Expr ()
mkName String
"buf"
                                                               ])
                                                               forall a. [a] -> [a] -> [a]
++ [Argument ()]
hasReply
                                                               forall a. [a] -> [a] -> [a]
++ [Argument ()
argChecked])
      requestBody :: Suite ()
requestBody = Suite ()
buf forall a. [a] -> [a] -> [a]
++ Suite ()
packStmts forall a. [a] -> [a] -> [a]
++ [Statement ()
ret]
      request :: Statement ()
request = String -> [Parameter ()] -> Suite () -> Statement ()
mkMethod String
name [Parameter ()]
allArgs Suite ()
requestBody
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall s (m :: * -> *). MonadState s m => m s
get
  let unpackF :: GenStructElem Type
-> Either
     (Maybe String, String)
     (String,
      Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
      Maybe Int)
unpackF = Expr ()
-> String
-> TypeInfoMap
-> GenStructElem Type
-> Either
     (Maybe String, String)
     (String,
      Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
      Maybe Int)
structElemToPyUnpack Expr ()
unpackerCopy String
ext TypeInfoMap
m
      ([Either
   (Maybe String, String)
   (String,
    Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
    Maybe Int)]
fields, [Either
   (Maybe String, String)
   (String,
    Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
    Maybe Int)]
listInfo) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span forall a b. Either a b -> Bool
EC.isLeft forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Maybe String, String) -> Suite ()
mkUnionUnpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Either a b -> a
EC.fromLeft') [Either
   (Maybe String, String)
   (String,
    Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
    Maybe Int)]
fields
      listInfo' :: [(String,
  Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
  Maybe Int)]
listInfo' = forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {p} {a}. p -> a
mkBaseUnpack forall a. a -> a
id) [Either
   (Maybe String, String)
   (String,
    Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])],
    Maybe Int)]
listInfo
      ([String]
names, [Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])]]
listOrSwitches, [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 ()]
_) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. Either a b -> a
EC.fromLeft' [Either (Expr (), Expr ()) [(Expr (), [GenStructElem Type])]]
listOrSwitches
      lists :: Suite ()
lists = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map String -> Expr ()
mkAttr [String]
names) [Expr ()]
exprs
      initMethod :: Suite ()
initMethod = Suite ()
lists 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 forall a. Maybe a
Nothing [forall a. [a] -> a
head [GenStructElem Type]
membs] forall a. Maybe a
Nothing
      decl :: Suite ()
decl = [String -> String -> Suite () -> Suite () -> Statement ()
mkXClass String
name String
"xcffib.Union" Suite ()
initMethod [Statement ()
pack]]
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify 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)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Suite () -> BindingPart
Declaration Suite ()
decl
  where
    unpackerCopy :: Expr ()
unpackerCopy = 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) =
      forall a. PseudoExpr a => a -> [String] -> String -> Suite ()
mkUnpackFrom Expr ()
unpackerCopy (forall a. Maybe a -> [a]
maybeToList Maybe String
n) String
typ

    mkBaseUnpack :: p -> a
mkBaseUnpack p
_ = forall a. HasCallStack => String -> a
error String
"xcffib: trailing base types unpack not implemented"

processXDecl String
ext (XidUnion String
name [GenXidUnionElem Type]
_) =
  -- These are always unions of only XIDs.
  do forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ String -> String -> TypeInfo -> TypeInfoMap -> TypeInfoMap
mkModify String
ext String
name (String -> TypeInfo
BaseType String
"I")
     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
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify 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)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Suite () -> BindingPart
Declaration 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" (forall typ. GenXHeader typ -> Maybe Int
xheader_major_version XHeader
header)
      minor :: Suite ()
minor = String -> Maybe Int -> Suite ()
ver String
"MINOR_VERSION" (forall typ. GenXHeader typ -> Maybe Int
xheader_minor_version XHeader
header)
  in Suite ()
major forall a. [a] -> [a] -> [a]
++ Suite ()
minor
  where
    ver :: String -> Maybe Int -> Suite ()
    ver :: String -> Maybe Int -> Suite ()
ver String
target Maybe Int
i = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
x -> 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 <- forall typ. GenXHeader typ -> Maybe String
xheader_xname XHeader
header
  let call :: Expr ()
call = forall a b. (PseudoExpr a, PseudoArgument b) => a -> [b] -> Expr ()
mkCall String
"xcffib.ExtensionKey" [String -> Expr ()
mkStr String
name]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. PseudoExpr a => a -> Expr () -> Statement ()
mkAssign String
"key" Expr ()
call