{-
 - 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 (Eq, Ord, Show)

type TypeInfoMap = M.Map X.Type TypeInfo

data BindingPart =
  Request (Statement ()) (Suite ()) |
  Declaration (Suite ()) |
  Noop
  deriving (Show)

collectBindings :: [BindingPart] -> (Suite (), Suite ())
collectBindings = foldr collectR ([], [])
  where
    collectR :: BindingPart -> (Suite (), Suite ()) -> (Suite (), Suite ())
    collectR (Request def decl) (defs, decls) = (def : defs, decl ++ decls)
    collectR (Declaration decl) (defs, decls) = (defs, decl ++ decls)
    collectR Noop x = x

parseXHeaders :: FilePath -> IO [XHeader]
parseXHeaders fp = do
  files <- namesMatching $ fp </> "*.xml"
  fromFiles files

renderPy :: Suite () -> String
renderPy s = ((intercalate "\n") $ map prettyText s) ++ "\n"

-- | 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 = map buildPython . dependencyOrder
  where
    buildPython :: Tree XHeader -> (String, Suite ())
    buildPython forest =
      let forest' = (mapM processXHeader $ postOrder forest)
          results = evalState forest' baseTypeInfo
      in last results
    processXHeader :: XHeader
                   -> State TypeInfoMap (String, Suite ())
    processXHeader header = do
      let imports = [mkImport "xcffib", mkImport "struct", mkImport "io"]
          version = mkVersion header
          key = maybeToList $ mkKey header
          globals = [mkDict "_events", mkDict "_errors"]
          name = xheader_header header
          add = [mkAddExt header]
      parts <- mapM (processXDecl name) $ xheader_decls header
      let (requests, decls) = collectBindings parts
          ext = if length requests > 0
                then [mkClass (name ++ "Extension") "xcffib.Extension" requests]
                else []
      return $ (name, concat [imports, version, key, globals, decls, ext, add])
    -- 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 headers = unfoldForest unfold $ map xheader_header headers
      where
        headerM = M.fromList $ map (\h -> (xheader_header h, h)) headers
        unfold s = let h = headerM M.! s in (h, deps h)
        deps :: XHeader -> [String]
        deps = catMaybes . map matchImport . xheader_decls
        matchImport :: XDecl -> Maybe String
        matchImport (XImport n) = Just n
        matchImport _ = Nothing
    postOrder :: Tree a -> [a]
    postOrder (Node e cs) = (concat $ map postOrder cs) ++ [e]


mkAddExt :: XHeader -> Statement ()
mkAddExt (xheader_header -> "xproto") =
  flip StmtExpr () $ mkCall "xcffib._add_core" [ mkName "xprotoExtension"
                                               , mkName "Setup"
                                               , mkName "_events"
                                               , mkName "_errors"
                                               ]
mkAddExt header =
  let name = xheader_header header
  in flip StmtExpr () $ mkCall "xcffib._add_ext" [ mkName "key"
                                                 , mkName (name ++ "Extension")
                                                 , mkName "_events"
                                                 , mkName "_errors"
                                                 ]

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

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

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

    lang = many $ (,) <$> optional decimal <*> (satisfy $ inClass $ M.keys sizeM)

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

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

xExpressionToNestedPyExpr :: (String -> String) -> XExpression -> Expr ()
xExpressionToNestedPyExpr acc (Op o e1 e2) =
  Paren (xExpressionToPyExpr acc (Op o e1 e2)) ()
xExpressionToNestedPyExpr acc xexpr =
  xExpressionToPyExpr acc xexpr

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

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

xEnumElemsToPyEnum :: (String -> String) -> [XEnumElem] -> [(String, Expr ())]
xEnumElemsToPyEnum accessor membs = reverse $ conv membs [] [0..]
  where
    exprConv = xExpressionToPyExpr accessor
    conv :: [XEnumElem] -> [(String, Expr ())] -> [Int] -> [(String, Expr ())]
    conv ((EnumElem name expr) : els) acc is =
      let expr' = fromMaybe (mkInt (head is)) $ fmap exprConv expr
          is' = dropWhile (<= (fromIntegral (int_value expr'))) is
          acc' = (name, expr') : acc
      in conv els acc' is'
    conv [] acc _ = acc

-- 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 prefix (c : cs) | c `elem` "Bbx" =
  let result = maybePrintChar prefix c
  in if result == prefix then result ++ (c : cs) else result ++ cs
addStructData prefix s = (maybePrintChar prefix 'x') ++ s

maybePrintChar :: String -> Char -> String
maybePrintChar s c | "%c" `isInfixOf` s = printf s c
maybePrintChar s _ = s

-- 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 1 = "x"
mkPad i = (show i) ++ "x"

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

-- XXX: This is a cheap hack for noop, we should really do better.
structElemToPyUnpack _ _ _ (Doc _ _ _) = Left (Nothing, "")
-- XXX: What does fd mean? we should implement it correctly
structElemToPyUnpack _ _ _ (Fd _) = Left (Nothing, "")
structElemToPyUnpack _ _ _ (Length _ _) = Left (Nothing, "")

-- The switch fields pick the way to expression to pack based on the expression
structElemToPyUnpack _ _ _ (Switch name expr _ bitcases) =
  let cmp = xExpressionToPyExpr ((++) "self.") expr
      switch = map (mkSwitch cmp) bitcases
  in Right (name, Right switch, Nothing)
    where
      mkSwitch :: Expr ()
               -> BitCase
               -> (Expr (), [GenStructElem Type])
      mkSwitch cmp (BitCase Nothing bcCmp _ elems) =
        let cmpVal = xExpressionToPyExpr id bcCmp
            equality = BinaryOp (P.BinaryAnd ()) cmp cmpVal ()
        in (equality, elems)

      mkSwitch cmp (BitCase (Just _) bcCmp _ elems) =
        let cmpVal = xExpressionToPyExpr id bcCmp
            equality = BinaryOp (P.Equality ()) cmp cmpVal ()
        in (equality, elems)

-- The enum field is mostly for user information, so we ignore it.
structElemToPyUnpack unpacker ext m (X.List n typ len _) =
  let attr = ((++) "self.")
      len' = fromMaybe pyNone $ fmap (xExpressionToPyExpr attr) len
      cons = case m M.! typ of
               BaseType c -> mkStr c
               CompositeType tExt c | ext /= tExt -> mkName $ tExt ++ "." ++ c
               CompositeType _ "DeviceTimeCoord" ->
                 let wrapper = mkName "xcffib.__DeviceTimeCoord_wrapper"
                 in mkCall wrapper [mkName "DeviceTimeCoord", mkName (attr "num_axes")]
               CompositeType _ c -> mkName c
      list = mkCall "xcffib.List" [ unpacker
                                  , cons
                                  , len'
                                  ]
      constLen = do
        l <- len
        getConst l
  in Right (n, Left (list, cons), constLen)

-- The mask and enum fields are for user information, we can ignore them here.
structElemToPyUnpack unpacker ext m (SField n typ _ _) =
  case m M.! typ of
    BaseType c -> Left (Just n, c)
    CompositeType tExt c ->
      let c' = if tExt == ext then c else tExt ++ "." ++ c
          field = mkCall c' [unpacker]
      -- TODO: Ugh. Nothing here is wrong. Do we really need to carry the
      -- length of these things around?
      in Right (n, Left (field, mkName c'), Nothing)
structElemToPyUnpack _ _ _ (ExprField _ _ _) = error "Only valid for requests"
structElemToPyUnpack _ _ _ (ValueParam _ _ _ _) = error "Only valid for requests"

structElemToPyPack :: String
                   -> TypeInfoMap
                   -> (String -> String)
                   -> GenStructElem Type
                   -> Either (Maybe String, String) [(String, Either (Maybe (Expr ()))
                                                                     [(Expr (), [GenStructElem Type])]
                                                    )]
structElemToPyPack _ _ _ (Pad _ i) = Left (Nothing, mkPad i)
-- TODO: implement these?
structElemToPyPack _ _ _ (Doc _ _ _) = Left (Nothing, "")
structElemToPyPack _ _ _ (Fd _) = Left (Nothing, "")
structElemToPyPack _ _ _ (Length _ _) = Left (Nothing, "")
structElemToPyPack _ _ accessor (Switch n expr _ bitcases) =
  let name = accessor n
      cmp = xExpressionToPyExpr accessor expr
      elems = map (mkSwitch cmp) bitcases
  in Right $ [(name, Right elems)]
    where
      mkSwitch :: Expr ()
               -> BitCase
               -> (Expr (), [GenStructElem Type])
      mkSwitch cmp (BitCase _ bcCmp _ elems') =
        let cmpVal = xExpressionToPyExpr accessor bcCmp
            equality = BinaryOp (P.BinaryAnd ()) cmp cmpVal ()
        in (equality, elems')
structElemToPyPack ext m accessor (SField n typ _ _) =
  let name = accessor n
  in case m M.! typ of
       BaseType c -> Left (Just name, c)
       CompositeType tExt typNam ->
         let cond = mkCall "hasattr" [mkArg name, ArgExpr (mkStr "pack") ()]
             trueB = mkCall (name ++ ".pack") noArgs
             typNam' = if ext == tExt then typNam else tExt ++ "." ++ typNam
             synthetic = mkCall (typNam' ++ ".synthetic") [mkArg ("*" ++ name)]
             falseB = mkCall (mkDot synthetic "pack") noArgs
         in Right $ [(name
                    , Left (Just (CondExpr trueB cond falseB ()))
                    )]
-- TODO: assert values are in enum?
structElemToPyPack ext m accessor (X.List n typ expr _) =
  let name = accessor 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 = if isNothing expr then [(name ++ "_len", Left Nothing)] else []
      list = case m M.! typ of
        BaseType c -> [(name
                      , Left (Just (mkCall "xcffib.pack_list" [ mkName $ name
                                                              , mkStr c
                                                              ]))
                      )]
        CompositeType tExt c ->
          let c' = if tExt == ext then c else (tExt ++ "." ++ c)
          in [(name
             , Left (Just (mkCall "xcffib.pack_list" ([ mkName $ name
                                                      , mkName c'
                                                      ])))
             )]
  in Right $ list_len ++ list
structElemToPyPack _ m accessor (ExprField name typ expr) =
  let e = (xExpressionToPyExpr accessor) expr
      name' = accessor name
  in case m M.! typ of
       BaseType c -> Right $ [(name'
                             , Left (Just (mkCall "struct.pack" [ mkStr ('=' : c)
                                                                , e
                                                                ]))
                             )]
       CompositeType _ _ -> Right $ [(name'
                                    , Left (Just (mkCall (mkDot e "pack") noArgs))
                                    )]

-- As near as I can tell here the padding param is unused.
structElemToPyPack _ m accessor (ValueParam typ mask _ list) =
  case m M.! typ of
    BaseType c ->
      let mask' = mkCall "struct.pack" [mkStr ('=' : c), mkName $ accessor mask]
          list' = mkCall "xcffib.pack_list" [ mkName $ accessor list
                                            , mkStr "I"
                                            ]
      in Right $ [(mask, Left (Just mask')), (list, Left (Just list'))]
    CompositeType _ _ -> error (
      "ValueParams other than CARD{16,32} not allowed.")

buf :: Suite ()
buf = [mkAssign "buf" (mkCall "io.BytesIO" noArgs)]

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

      mkListWrite :: Expr ()
                  -> Statement ()
      mkListWrite expr' = flip StmtExpr () . mkCall "buf.write" $ (: []) expr'

      mkPop :: String
            -> String
            -> Statement ()
      mkPop toPop n =
        let pop = mkCall (mkDot toPop "pop") [mkInt 0]
        in if null n then StmtExpr pop () else mkAssign n pop

      mkBasePack (Nothing, "") = []
      mkBasePack (n, c) =
        let n' = maybe "" id n
        in [(n', Left (Just (mkCall "struct.pack" [mkStr ('=' : c), mkName n'])))]

mkPackMethod :: String
             -> String
             -> TypeInfoMap
             -> Maybe (String, Int)
             -> [GenStructElem Type]
             -> Maybe Int
             -> Statement ()
mkPackMethod ext name m prefixAndOp structElems minLen =
  let accessor = ((++) "self.")
      (prefix, op) = case prefixAndOp of
                        Just ('x' : rest, i) ->
                          let packOpcode = mkCall "struct.pack" [mkStr "=B", mkInt i]
                              write = mkCall "buf.write" [packOpcode]
                          in (rest, [StmtExpr write ()])
                        Just (rest, _) -> error ("internal API error: " ++ show rest)
                        Nothing -> ("", [])
      (_, packStmts) = mkPackStmts ext name m accessor prefix structElems
      extend = concat $ do
        len <- maybeToList minLen
        let bufLen = mkName "buf_len"
            bufLenAssign = mkAssign bufLen $ mkCall "len" [mkCall "buf.getvalue" noArgs]
            test = (BinaryOp (LessThan ()) bufLen (mkInt len)) ()
            bufWriteLen = Paren (BinaryOp (Minus ()) (mkInt 32) bufLen ()) ()
            extra = mkCall "struct.pack" [repeatStr "x" bufWriteLen]
            writeExtra = [StmtExpr (mkCall "buf.write" [extra]) ()]
        return $ [bufLenAssign, mkIf test writeExtra]
      ret = [mkReturn $ mkCall "buf.getvalue" noArgs]
  in mkMethod "pack" (mkParams ["self"]) $ buf ++ op ++ packStmts ++ extend ++ ret

data StructUnpackState = StructUnpackState {
  -- | stNeedsPad 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.
  stNeedsPad :: Bool,

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

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

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

    where
      -- 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 [] = flushAcc

      mkUnpackStmts (Left (name, pack) : xs) = do
        st <- get
        let packs = if "%c" `isInfixOf` (stPacks st)
                    then addStructData (stPacks st) pack
                    else (stPacks st) ++ pack
        put $ st { stNames = stNames st ++ maybeToList name
                 , stPacks = packs
                 }
        mkUnpackStmts xs

      mkUnpackStmts (Right (thisName, listOrSwitch, thisSz) : xs) = do
        (packNames, packStmt, packSz) <- flushAcc
        st <- get
        put $ st { stNeedsPad = True }
        let thisStmts = mkUnpackListOrSwitch thisName listOrSwitch (stNeedsPad st) st
        (restNames, restStmts, restSz) <- mkUnpackStmts xs
        let totalSize = do
                          before <- packSz
                          rest <- restSz
                          thisSz' <- thisSz
                          return $ before + rest + thisSz'
        return ( packNames ++ [thisName] ++ restNames
               , packStmt ++ thisStmts ++ restStmts
               , totalSize
               )
          where
            mkUnpackListOrSwitch :: String
                                 -> Either (Expr (), Expr ())
                                           ([(Expr (), [GenStructElem Type])])
                                 -> Bool
                                 -> StructUnpackState
                                 -> Suite ()
            mkUnpackListOrSwitch name' (Left (list, cons)) needsPad _ =
              let pad = if needsPad
                        then [typePad cons]
                        else []
              in pad ++ [mkAssign (mkAttr name') list]
            mkUnpackListOrSwitch _ (Right switchList) _ st' =
              let (conds, elems) = unzip switchList
                  stmts = map (mkUnpackSwitchElems st') elems
              in map (\x -> Conditional [x] [] ()) $ zip conds stmts

            mkUnpackSwitchElems :: StructUnpackState
                                -> [GenStructElem Type]
                                -> Suite ()
            mkUnpackSwitchElems st' elems' =
              let unpacked' = map (structElemToPyUnpack (mkName "unpacker") ext m) elems'
                  (_, stmts', _) = evalState (mkUnpackStmts unpacked') st'
              in stmts'

      flushAcc :: State StructUnpackState ([String], Suite (), Maybe Int)
      flushAcc = do
        StructUnpackState needsPad args keys <- get
        let size = calcsize keys
            assign = mkUnpackFrom "unpacker" args keys
        put $ StructUnpackState needsPad [] ""
        return (args, assign, Just size)

      typePad e = StmtExpr (mkCall "unpacker.pad" [e]) ()

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

mkSyntheticMethod :: [GenStructElem Type] -> [Statement ()]
mkSyntheticMethod membs = do
  let names = catMaybes $ map getName membs
      args = mkParams $ "cls" : names
      self = mkAssign "self" $ mkCall (mkDot "cls" "__new__") [mkName "cls"]
      body = map assign names
      ret = mkReturn $ mkName "self"
      synthetic = mkMethod "synthetic" args $ (self : body) ++ [ret]
      classmethod = Decorator [ident "classmethod"] noArgs ()
  if null names then [] else [Decorated [classmethod] synthetic ()]
    where
      getName :: GenStructElem Type -> Maybe String
      getName (Pad _ _) = Nothing
      getName (X.List n _ _ _) = Just n
      getName (SField n _ _ _) = Just n
      getName (ExprField n _ _) = Just n
      getName (ValueParam _ n _ _) = Just n
      getName (Switch n _ _ _) = Just n
      getName (Doc _ _ _) = Nothing
      getName (Fd n) = Just n
      getName (Length _ _) = Nothing

      assign :: String -> Statement ()
      assign n = mkAssign (mkDot "self" n) $ mkName n

processXDecl :: String
             -> XDecl
             -> State TypeInfoMap BindingPart
processXDecl ext (XTypeDef name typ) =
  do modify $ \m -> mkModify ext name (m M.! typ) m
     return Noop
processXDecl ext (XidType name) =
  -- http://www.markwitmer.com/guile-xcb/doc/guile-xcb/XIDs.html
  do modify $ mkModify ext name (BaseType "I")
     return Noop
processXDecl _ (XImport n) =
  return $ Declaration [ mkRelImport n]
processXDecl _ (XEnum name membs) =
  return $ Declaration [mkEnum name $ xEnumElemsToPyEnum id membs]
processXDecl ext (XStruct n _ membs) = do
  m <- get
  let (statements, len) = mkStructStyleUnpack "" ext m membs
      pack = mkPackMethod ext n m Nothing membs Nothing
      synthetic = mkSyntheticMethod membs
      fixedLength = maybeToList $ do
        theLen <- len
        let rhs = mkInt theLen
        return $ mkAssign "fixed_size" rhs
  modify $ mkModify ext n (CompositeType ext n)
  return $ Declaration [mkXClass n "xcffib.Struct" False statements (pack : fixedLength ++ synthetic)]
processXDecl ext (XEvent name opcode _ xge membs noSequence) = do
  m <- get
  let cname = name ++ "Event"
      prefix = if fromMaybe False noSequence then "x" else "x%c2x"
      pack = mkPackMethod ext name m (Just (prefix, opcode)) membs (Just 32)
      synthetic = mkSyntheticMethod membs
      (statements, _) = mkStructStyleUnpack prefix ext m membs
      eventsUpd = mkDictUpdate "_events" opcode cname
      isxge = fromMaybe False xge
      -- xgeexp = mkAssign "xge" (if fromMaybe False xge then (mkName "True") else (mkName "False"))
  return $ Declaration [ mkXClass cname "xcffib.Event" isxge statements (pack : synthetic)
                       , eventsUpd
                       ]
processXDecl ext (XError name opcode _ membs) = do
  m <- get
  let cname = name ++ "Error"
      prefix = "xx2x"
      pack = mkPackMethod ext name m (Just (prefix, opcode)) membs Nothing
      (statements, _) = mkStructStyleUnpack prefix ext m membs
      errorsUpd = mkDictUpdate "_errors" opcode cname
      alias = mkAssign ("Bad" ++ name) (mkName cname)
  return $ Declaration [ mkXClass cname "xcffib.Error" False statements [pack]
                       , alias
                       , errorsUpd
                       ]
processXDecl ext (XRequest name opcode _ membs reply) = do
  m <- 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 = if ext /= "xproto" then "xx2x" else "x%c2x"
      (args, packStmts) = mkPackStmts ext name m id prefix membs
      cookieName = (name ++ "Cookie")
      replyDecl = concat $ maybeToList $ do
        GenXReply _ reply' <- reply
        let (replyStmts, _) = mkStructStyleUnpack "x%c2x4x" ext m reply'
            replyName = name ++ "Reply"
            theReply = mkXClass replyName "xcffib.Reply" False replyStmts []
            replyType = mkAssign "reply_type" $ mkName replyName
            cookie = mkClass cookieName "xcffib.Cookie" [replyType]
        return [theReply, cookie]

      hasReply = if length replyDecl > 0
                 then [ArgExpr (mkName cookieName) ()]
                 else []
      isChecked = pyTruth $ isJust reply
      argChecked = ArgKeyword (ident "is_checked") (mkName "is_checked") ()
      checkedParam = Param (ident "is_checked") Nothing (Just isChecked) ()
      allArgs = (mkParams $ "self" : (filter (not . null) args)) ++ [checkedParam]
      mkArg' = flip ArgExpr ()
      ret = mkReturn $ mkCall "self.send_request" ((map mkArg' [ mkInt opcode
                                                               , mkName "buf"
                                                               ])
                                                               ++ hasReply
                                                               ++ [argChecked])
      requestBody = buf ++ packStmts ++ [ret]
      request = mkMethod name allArgs requestBody
  return $ Request request replyDecl
processXDecl ext (XUnion name _ membs) = do
  m <- get
  let unpackF = structElemToPyUnpack unpackerCopy ext m
      (fields, listInfo) = span EC.isLeft $ map unpackF membs
      toUnpack = concat $ map (mkUnionUnpack . EC.fromLeft') fields
      listInfo' = map (either mkBaseUnpack id) listInfo
      (names, listOrSwitches, _) = unzip3 listInfo'
      (exprs, _) = unzip $ map EC.fromLeft' listOrSwitches
      lists = map (uncurry mkAssign) $ zip (map mkAttr names) exprs
      initMethod = lists ++ toUnpack
      -- Here, we only want to pack the first member of the union, since every
      -- member is the same data and we don't want to repeatedly pack it.
      pack = mkPackMethod ext name m Nothing [head membs] Nothing
      decl = [mkXClass name "xcffib.Union" False initMethod [pack]]
  modify $ mkModify ext name (CompositeType ext name)
  return $ Declaration decl
  where
    unpackerCopy = mkCall "unpacker.copy" noArgs
    mkUnionUnpack :: (Maybe String, String)
                  -> Suite ()
    mkUnionUnpack (n, typ) =
      mkUnpackFrom unpackerCopy (maybeToList n) typ

    mkBaseUnpack _ = error "xcffib: trailing base types unpack not implemented"

processXDecl ext (XidUnion name _) =
  -- These are always unions of only XIDs.
  do modify $ mkModify ext name (BaseType "I")
     return 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 ext (XEventStruct name _) = do
  modify $ mkModify ext name (CompositeType ext name)
  return $ Declaration $ [mkXClass name "xcffib.Buffer" False [] []]

mkVersion :: XHeader -> Suite ()
mkVersion header =
  let major = ver "MAJOR_VERSION" (xheader_major_version header)
      minor = ver "MINOR_VERSION" (xheader_minor_version header)
  in major ++ minor
  where
    ver :: String -> Maybe Int -> Suite ()
    ver target i = maybeToList $ fmap (\x -> mkAssign target (mkInt x)) i

mkKey :: XHeader -> Maybe (Statement ())
mkKey header = do
  name <- xheader_xname header
  let call = mkCall "xcffib.ExtensionKey" [mkStr name]
  return $ mkAssign "key" call