Date: Monday, December 26, 2016 @ 04:39:56 Author: felixonmars Revision: 202577
upgpkg: haskell-xcb-types 0.7.1-6 add proposed patch for xcb 1.12 Added: haskell-xcb-types/trunk/xcb-1.12.patch Modified: haskell-xcb-types/trunk/PKGBUILD ----------------+ PKGBUILD | 13 + xcb-1.12.patch | 445 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 455 insertions(+), 3 deletions(-) Modified: PKGBUILD =================================================================== --- PKGBUILD 2016-12-26 04:19:54 UTC (rev 202576) +++ PKGBUILD 2016-12-26 04:39:56 UTC (rev 202577) @@ -5,15 +5,22 @@ _hkgname=xcb-types pkgname=haskell-xcb-types pkgver=0.7.1 -pkgrel=5 +pkgrel=6 pkgdesc="Parses XML files used by the XCB project" url="http://hackage.haskell.org/package/${_hkgname}"; license=("custom:BSD3") arch=('i686' 'x86_64') depends=("ghc=8.0.1" 'haskell-mtl' 'haskell-xml') -source=("http://hackage.haskell.org/packages/archive/${_hkgname}/${pkgver}/${_hkgname}-${pkgver}.tar.gz";) -sha256sums=('5927e720e4dee26b1bf8a24fb07e47e6a22f9d78fc87aab8d752f207c1566782') +source=("http://hackage.haskell.org/packages/archive/${_hkgname}/${pkgver}/${_hkgname}-${pkgver}.tar.gz"; + xcb-1.12.patch) +sha256sums=('5927e720e4dee26b1bf8a24fb07e47e6a22f9d78fc87aab8d752f207c1566782' + '735b98510f4e2f21ae5ad3c5d54dd1a47666a98055637045e320fb9bb7032a81') +prepare() { + cd ${_hkgname}-${pkgver} + patch -p1 -i ../xcb-1.12.patch +} + build() { cd "${srcdir}/${_hkgname}-${pkgver}" Added: xcb-1.12.patch =================================================================== --- xcb-1.12.patch (rev 0) +++ xcb-1.12.patch 2016-12-26 04:39:56 UTC (rev 202577) @@ -0,0 +1,445 @@ +From a86e578f0860670f3d43fa2d414e93a60aa72e2d Mon Sep 17 00:00:00 2001 +From: Tycho Andersen <[email protected]> +Date: Sun, 12 Jun 2016 19:49:16 -0600 +Subject: [PATCH] add support for new element "required_start_align" + +This is a little bit ugly and it breaks the API, but it's necessary since +upstream has added this and xcb-types won't parse xcb-proto 1.12 as-is. + +Signed-off-by: Tycho Andersen <[email protected]> +--- + Data/XCB/FromXML.hs | 84 ++++++++++++++++++++++++++++++++--------------------- + Data/XCB/Pretty.hs | 41 +++++++++++++++----------- + Data/XCB/Types.hs | 22 ++++++++------ + 3 files changed, 88 insertions(+), 59 deletions(-) + +diff --git a/Data/XCB/FromXML.hs b/Data/XCB/FromXML.hs +index 67ce9e1..af44a19 100644 +--- a/Data/XCB/FromXML.hs ++++ b/Data/XCB/FromXML.hs +@@ -73,6 +73,16 @@ localName = snd `liftM` ask + allModules :: Parse [XHeader] + allModules = fst `liftM` ask + ++-- Extract an Alignment from a list of Elements. This assumes that the ++-- required_start_align is the first element if it exists at all. ++extractAlignment :: (MonadPlus m, Functor m) => [Element] -> m (Maybe Alignment, [Element]) ++extractAlignment (el : xs) | el `named` "required_start_align" = do ++ align <- el `attr` "align" >>= readM ++ offset <- el `attr` "offset" >>= readM ++ return (Just (Alignment align offset), xs) ++ | otherwise = return (Nothing, el : xs) ++extractAlignment xs = return (Nothing, xs) ++ + -- a generic function for looking up something from + -- a named XHeader. + -- +@@ -108,23 +118,23 @@ findError :: Name -> [XDecl] -> Maybe ErrorDetails + findError pname xs = + case List.find f xs of + Nothing -> Nothing +- Just (XError name code elems) -> Just $ ErrorDetails name code elems ++ Just (XError name code alignment elems) -> Just $ ErrorDetails name code alignment elems + _ -> error "impossible: fatal error in Data.XCB.FromXML.findError" +- where f (XError name _ _) | name == pname = True ++ where f (XError name _ _ _) | name == pname = True + f _ = False + + findEvent :: Name -> [XDecl] -> Maybe EventDetails + findEvent pname xs = + case List.find f xs of + Nothing -> Nothing +- Just (XEvent name code elems noseq) -> +- Just $ EventDetails name code elems noseq ++ Just (XEvent name code alignment elems noseq) -> ++ Just $ EventDetails name code alignment elems noseq + _ -> error "impossible: fatal error in Data.XCB.FromXML.findEvent" +- where f (XEvent name _ _ _) | name == pname = True ++ where f (XEvent name _ _ _ _) | name == pname = True + f _ = False + +-data EventDetails = EventDetails Name Int [StructElem] (Maybe Bool) +-data ErrorDetails = ErrorDetails Name Int [StructElem] ++data EventDetails = EventDetails Name Int (Maybe Alignment) [StructElem] (Maybe Bool) ++data ErrorDetails = ErrorDetails Name Int (Maybe Alignment) [StructElem] + + --- + +@@ -194,25 +204,28 @@ xrequest el = do + code <- el `attr` "opcode" >>= readM + -- TODO - I don't think I like 'mapAlt' here. + -- I don't want to be silently dropping fields +- fields <- mapAlt structField $ elChildren el ++ (alignment, xs) <- extractAlignment $ elChildren el ++ fields <- mapAlt structField $ xs + let reply = getReply el +- return $ XRequest nm code fields reply ++ return $ XRequest nm code alignment fields reply + + getReply :: Element -> Maybe XReply + getReply el = do + childElem <- unqual "reply" `findChild` el +- fields <- mapM structField $ elChildren childElem ++ (alignment, xs) <- extractAlignment $ elChildren childElem ++ fields <- mapM structField xs + guard $ not $ null fields +- return fields ++ return $ GenXReply alignment fields + + xevent :: Element -> Parse XDecl + xevent el = do + name <- el `attr` "name" + number <- el `attr` "number" >>= readM + let noseq = ensureUpper `liftM` (el `attr` "no-sequence-number") >>= readM +- fields <- mapM structField $ elChildren el ++ (alignment, xs) <- extractAlignment (elChildren el) ++ fields <- mapM structField $ xs + guard $ not $ null fields +- return $ XEvent name number fields noseq ++ return $ XEvent name number alignment fields noseq + + xevcopy :: Element -> Parse XDecl + xevcopy el = do +@@ -222,12 +235,12 @@ xevcopy el = do + -- do we have a qualified ref? + let (mname,evname) = splitRef ref + details <- lookupEvent mname evname +- return $ let EventDetails _ _ fields noseq = ++ return $ let EventDetails _ _ alignment fields noseq = + case details of + Nothing -> + error $ "Unresolved event: " ++ show mname ++ " " ++ ref + Just x -> x +- in XEvent name number fields noseq ++ in XEvent name number alignment fields noseq + + -- we need to do string processing to distinguish qualified from + -- unqualified types. +@@ -258,8 +271,9 @@ xerror :: Element -> Parse XDecl + xerror el = do + name <- el `attr` "name" + number <- el `attr` "number" >>= readM +- fields <- mapM structField $ elChildren el +- return $ XError name number fields ++ (alignment, xs) <- extractAlignment $ elChildren el ++ fields <- mapM structField $ xs ++ return $ XError name number alignment fields + + + xercopy :: Element -> Parse XDecl +@@ -269,23 +283,25 @@ xercopy el = do + ref <- el `attr` "ref" + let (mname, ername) = splitRef ref + details <- lookupError mname ername +- return $ XError name number $ case details of ++ return $ uncurry (XError name number) $ case details of + Nothing -> error $ "Unresolved error: " ++ show mname ++ " " ++ ref +- Just (ErrorDetails _ _ x) -> x ++ Just (ErrorDetails _ _ alignment elems) -> (alignment, elems) + + xstruct :: Element -> Parse XDecl + xstruct el = do + name <- el `attr` "name" +- fields <- mapAlt structField $ elChildren el ++ (alignment, xs) <- extractAlignment $ elChildren el ++ fields <- mapAlt structField $ xs + guard $ not $ null fields +- return $ XStruct name fields ++ return $ XStruct name alignment fields + + xunion :: Element -> Parse XDecl + xunion el = do + name <- el `attr` "name" +- fields <- mapAlt structField $ elChildren el ++ (alignment, xs) <- extractAlignment $ elChildren el ++ fields <- mapAlt structField $ xs + guard $ not $ null fields +- return $ XUnion name fields ++ return $ XUnion name alignment fields + + xidtype :: Element -> Parse XDecl + xidtype el = liftM XidType $ el `attr` "name" +@@ -340,8 +356,9 @@ structField el + nm <- el `attr` "name" + (exprEl,caseEls) <- unconsChildren el + expr <- expression exprEl +- cases <- mapM bitCase caseEls +- return $ Switch nm expr cases ++ (alignment, xs) <- extractAlignment $ caseEls ++ cases <- mapM bitCase xs ++ return $ Switch nm expr alignment cases + + | el `named` "exprfield" = do + typ <- liftM mkType $ el `attr` "type" +@@ -371,15 +388,16 @@ structField el + ++ show name + + bitCase :: (MonadPlus m, Functor m) => Element -> m BitCase +-bitCase el | el `named` "bitcase" = do +- let mName = el `attr` "name" +- (exprEl, fieldEls) <- unconsChildren el +- expr <- expression exprEl +- fields <- mapM structField fieldEls +- return $ BitCase mName expr fields ++bitCase el | el `named` "bitcase" || el `named` "case" = do ++ let mName = el `attr` "name" ++ (exprEl, fieldEls) <- unconsChildren el ++ expr <- expression exprEl ++ (alignment, xs) <- extractAlignment $ fieldEls ++ fields <- mapM structField xs ++ return $ BitCase mName expr alignment fields + | otherwise = +- let name = elName el +- in error $ "Invalid bitCase: " ++ show name ++ let name = elName el ++ in error $ "Invalid bitCase: " ++ show name + + expression :: (MonadPlus m, Functor m) => Element -> m XExpression + expression el | el `named` "fieldref" +diff --git a/Data/XCB/Pretty.hs b/Data/XCB/Pretty.hs +index 9c7859c..156d154 100644 +--- a/Data/XCB/Pretty.hs ++++ b/Data/XCB/Pretty.hs +@@ -104,9 +104,9 @@ instance Pretty a => Pretty (GenStructElem a) where + toDoc (ExprField nm typ expr) + = parens (text nm <+> text "::" <+> toDoc typ) + <+> toDoc expr +- toDoc (Switch name expr cases) ++ toDoc (Switch name expr alignment cases) + = vcat +- [ text "switch" <> parens (toDoc expr) <> brackets (text name) ++ [ text "switch" <> parens (toDoc expr) <> toDoc alignment <> brackets (text name) + , braces (vcat (map toDoc cases)) + ] + toDoc (Doc brief fields see) +@@ -144,10 +144,12 @@ instance Pretty a => Pretty (GenStructElem a) where + ,text lname + ] + ++ + instance Pretty a => Pretty (GenBitCase a) where +- toDoc (BitCase name expr fields) ++ toDoc (BitCase name expr alignment fields) + = vcat + [ bitCaseHeader name expr ++ , toDoc alignment + , braces (vcat (map toDoc fields)) + ] + +@@ -157,28 +159,33 @@ bitCaseHeader Nothing expr = + bitCaseHeader (Just name) expr = + text "bitcase" <> parens (toDoc expr) <> brackets (text name) + ++instance Pretty Alignment where ++ toDoc (Alignment align offset) = text "alignment" <+> ++ text "align=" <+> toDoc align <+> ++ text "offset=" <+> toDoc offset ++ + instance Pretty a => Pretty (GenXDecl a) where +- toDoc (XStruct nm elems) = +- hang (text "Struct:" <+> text nm) 2 $ vcat $ map toDoc elems ++ toDoc (XStruct nm alignment elems) = ++ hang (text "Struct:" <+> text nm <+> toDoc alignment) 2 $ vcat $ map toDoc elems + toDoc (XTypeDef nm typ) = hsep [text "TypeDef:" + ,text nm + ,text "as" + ,toDoc typ + ] +- toDoc (XEvent nm n elems (Just True)) = +- hang (text "Event:" <+> text nm <> char ',' <> toDoc n <+> ++ toDoc (XEvent nm n alignment elems (Just True)) = ++ hang (text "Event:" <+> text nm <> char ',' <> toDoc n <+> toDoc alignment <+> + parens (text "No sequence number")) 2 $ + vcat $ map toDoc elems +- toDoc (XEvent nm n elems _) = +- hang (text "Event:" <+> text nm <> char ',' <> toDoc n) 2 $ ++ toDoc (XEvent nm n alignment elems _) = ++ hang (text "Event:" <+> text nm <> char ',' <> toDoc n <+> toDoc alignment) 2 $ + vcat $ map toDoc elems +- toDoc (XRequest nm n elems mrep) = +- (hang (text "Request:" <+> text nm <> char ',' <> toDoc n) 2 $ ++ toDoc (XRequest nm n alignment elems mrep) = ++ (hang (text "Request:" <+> text nm <> char ',' <> toDoc n <+> toDoc alignment) 2 $ + vcat $ map toDoc elems) + $$ case mrep of + Nothing -> empty +- Just reply -> +- hang (text "Reply:" <+> text nm <> char ',' <> toDoc n) 2 $ ++ Just (GenXReply repAlignment reply) -> ++ hang (text "Reply:" <+> text nm <> char ',' <> toDoc n <+> toDoc repAlignment) 2 $ + vcat $ map toDoc reply + toDoc (XidType nm) = text "XID:" <+> text nm + toDoc (XidUnion nm elems) = +@@ -186,11 +193,11 @@ instance Pretty a => Pretty (GenXDecl a) where + vcat $ map toDoc elems + toDoc (XEnum nm elems) = + hang (text "Enum:" <+> text nm) 2 $ vcat $ map toDoc elems +- toDoc (XUnion nm elems) = +- hang (text "Union:" <+> text nm) 2 $ vcat $ map toDoc elems ++ toDoc (XUnion nm alignment elems) = ++ hang (text "Union:" <+> text nm <+> toDoc alignment) 2 $ vcat $ map toDoc elems + toDoc (XImport nm) = text "Import:" <+> text nm +- toDoc (XError nm _n elems) = +- hang (text "Error:" <+> text nm) 2 $ vcat $ map toDoc elems ++ toDoc (XError nm _n alignment elems) = ++ hang (text "Error:" <+> text nm <+> toDoc alignment) 2 $ vcat $ map toDoc elems + + instance Pretty a => Pretty (GenXHeader a) where + toDoc xhd = text (xheader_header xhd) $$ +diff --git a/Data/XCB/Types.hs b/Data/XCB/Types.hs +index f4d2d7a..1b4fce3 100644 +--- a/Data/XCB/Types.hs ++++ b/Data/XCB/Types.hs +@@ -30,7 +30,7 @@ module Data.XCB.Types + , GenXDecl ( .. ) + , GenStructElem ( .. ) + , GenBitCase ( .. ) +- , GenXReply ++ , GenXReply ( .. ) + , GenXidUnionElem ( .. ) + , EnumElem ( .. ) + , Expression ( .. ) +@@ -44,6 +44,7 @@ module Data.XCB.Types + , MaskName + , ListName + , MaskPadding ++ , Alignment ( .. ) + ) where + + import Data.Map +@@ -78,16 +79,16 @@ type XEnumElem = EnumElem Type + -- |The different types of declarations which can be made in one of the + -- XML files. + data GenXDecl typ +- = XStruct Name [GenStructElem typ] ++ = XStruct Name (Maybe Alignment) [GenStructElem typ] + | XTypeDef Name typ +- | XEvent Name Int [GenStructElem typ] (Maybe Bool) -- ^ The boolean indicates if the event includes a sequence number. +- | XRequest Name Int [GenStructElem typ] (Maybe (GenXReply typ)) ++ | XEvent Name Int (Maybe Alignment) [GenStructElem typ] (Maybe Bool) -- ^ The boolean indicates if the event includes a sequence number. ++ | XRequest Name Int (Maybe Alignment) [GenStructElem typ] (Maybe (GenXReply typ)) + | XidType Name + | XidUnion Name [GenXidUnionElem typ] + | XEnum Name [EnumElem typ] +- | XUnion Name [GenStructElem typ] ++ | XUnion Name (Maybe Alignment) [GenStructElem typ] + | XImport Name +- | XError Name Int [GenStructElem typ] ++ | XError Name Int (Maybe Alignment) [GenStructElem typ] + deriving (Show, Functor) + + data GenStructElem typ +@@ -96,20 +97,21 @@ data GenStructElem typ + | SField Name typ (Maybe (EnumVals typ)) (Maybe (MaskVals typ)) + | ExprField Name typ (Expression typ) + | ValueParam typ Name (Maybe MaskPadding) ListName +- | Switch Name (Expression typ) [GenBitCase typ] ++ | Switch Name (Expression typ) (Maybe Alignment) [GenBitCase typ] + | Doc (Maybe String) (Map Name String) [(String, String)] + | Fd String + deriving (Show, Functor) + + data GenBitCase typ +- = BitCase (Maybe Name) (Expression typ) [GenStructElem typ] ++ = BitCase (Maybe Name) (Expression typ) (Maybe Alignment) [GenStructElem typ] + deriving (Show, Functor) + + type EnumVals typ = typ + type MaskVals typ = typ + + type Name = String +-type GenXReply typ = [GenStructElem typ] ++data GenXReply typ = GenXReply (Maybe Alignment) [GenStructElem typ] ++ deriving (Show, Functor) + type Ref = String + type MaskName = Name + type ListName = Name +@@ -150,3 +152,5 @@ data Binop = Add + + data Unop = Complement + deriving (Show) ++ ++data Alignment = Alignment Int Int deriving (Show) +From 0991f1d61b92371e9af51ab0fa3699d7c32e2b65 Mon Sep 17 00:00:00 2001 +From: Tycho Andersen <[email protected]> +Date: Sat, 6 Aug 2016 11:38:09 -0600 +Subject: [PATCH] add new expression element "paramref" + +Signed-off-by: Tycho Andersen <[email protected]> +--- + Data/XCB/FromXML.hs | 2 ++ + Data/XCB/Pretty.hs | 1 + + Data/XCB/Types.hs | 1 + + 3 files changed, 4 insertions(+) + +diff --git a/Data/XCB/FromXML.hs b/Data/XCB/FromXML.hs +index af44a19..951c302 100644 +--- a/Data/XCB/FromXML.hs ++++ b/Data/XCB/FromXML.hs +@@ -428,6 +428,8 @@ expression el | el `named` "fieldref" + | el `named` "sumof" = do + ref <- el `attr` "ref" + return $ SumOf ref ++ | el `named` "paramref" ++ = return $ ParamRef $ strContent el + | otherwise = + let nm = elName el + in error $ "Unknown epression " ++ show nm ++ " in Data.XCB.FromXML.expression" +diff --git a/Data/XCB/Pretty.hs b/Data/XCB/Pretty.hs +index 156d154..1f2b473 100644 +--- a/Data/XCB/Pretty.hs ++++ b/Data/XCB/Pretty.hs +@@ -90,6 +90,7 @@ instance Pretty a => Pretty (Expression a) where + ] + toDoc (Unop op expr) + = parens $ toDoc op <> toDoc expr ++ toDoc (ParamRef n) = toDoc n + + instance Pretty a => Pretty (GenStructElem a) where + toDoc (Pad n) = braces $ toDoc n <+> text "bytes" +diff --git a/Data/XCB/Types.hs b/Data/XCB/Types.hs +index 1b4fce3..8ec9ea3 100644 +--- a/Data/XCB/Types.hs ++++ b/Data/XCB/Types.hs +@@ -139,6 +139,7 @@ data Expression typ + | SumOf Name -- ^Note sure. The argument should be a reference to a list + | Op Binop (Expression typ) (Expression typ) -- ^A binary opeation + | Unop Unop (Expression typ) -- ^A unary operation ++ | ParamRef Name -- ^I think this is the name of an argument passed to the request. See fffbd04d63 in xcb-proto. + deriving (Show, Functor) + + -- |Supported Binary operations. +From 239afedc8678494684e8a81d4ffb6d7ccb3a052e Mon Sep 17 00:00:00 2001 +From: Tycho Andersen <[email protected]> +Date: Sun, 7 Aug 2016 09:40:12 -0600 +Subject: [PATCH] Alignment's "offset" is optional + +Signed-off-by: Tycho Andersen <[email protected]> +--- + Data/XCB/FromXML.hs | 2 +- + Data/XCB/Types.hs | 2 +- + 2 files changed, 2 insertions(+), 2 deletions(-) + +diff --git a/Data/XCB/FromXML.hs b/Data/XCB/FromXML.hs +index 951c302..ed6e59c 100644 +--- a/Data/XCB/FromXML.hs ++++ b/Data/XCB/FromXML.hs +@@ -78,7 +78,7 @@ allModules = fst `liftM` ask + extractAlignment :: (MonadPlus m, Functor m) => [Element] -> m (Maybe Alignment, [Element]) + extractAlignment (el : xs) | el `named` "required_start_align" = do + align <- el `attr` "align" >>= readM +- offset <- el `attr` "offset" >>= readM ++ let offset = el `attr` "offset" >>= readM + return (Just (Alignment align offset), xs) + | otherwise = return (Nothing, el : xs) + extractAlignment xs = return (Nothing, xs) +diff --git a/Data/XCB/Types.hs b/Data/XCB/Types.hs +index 8ec9ea3..b31542e 100644 +--- a/Data/XCB/Types.hs ++++ b/Data/XCB/Types.hs +@@ -154,4 +154,4 @@ data Binop = Add + data Unop = Complement + deriving (Show) + +-data Alignment = Alignment Int Int deriving (Show) ++data Alignment = Alignment Int (Maybe Int) deriving (Show)
