xcb-types 0.6.3 → 0.7.0

raw patch · 4 files changed

+175/−86 lines, 4 filesdep +containersdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• Data/XCB/FromXML.hs +79/−9
• Data/XCB/Pretty.hs +51/−4
• Data/XCB/Types.hs +39/−71
• xcb-types.cabal +6/−2

@@ -25,8 +25,10 @@ import Text.XML.Light  import Data.List as List+import qualified Data.Map as Map import Data.Maybe +import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.Reader @@ -41,6 +43,8 @@   strings <- sequence $ map readFileUTF8 xs   return $ fromStrings strings +-- | Like 'readFile', but forces the encoding+-- of the file to UTF8. readFileUTF8 :: FilePath -> IO String readFileUTF8 fp = do   h <- openFile fp ReadMode@@ -177,7 +181,7 @@   guard $ not $ null fields   return $ XEnum nm fields -enumField :: Element -> Parse EnumElem+enumField :: Element -> Parse (EnumElem Type) enumField el = do   guard $ el `named` "item"   name <- el `attr` "name"@@ -188,6 +192,8 @@ xrequest el = do   nm <- el `attr` "name"   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   let reply = getReply el   return $ XRequest nm code fields reply@@ -195,7 +201,7 @@ getReply :: Element -> Maybe XReply getReply el = do   childElem <- unqual "reply" `findChild` el-  let fields = mapMaybe structField $ elChildren childElem+  fields <- mapM structField $ elChildren childElem   guard $ not $ null fields   return fields @@ -204,7 +210,7 @@   name <- el `attr` "name"   number <- el `attr` "number" >>= readM   let noseq = ensureUpper `liftM` (el `attr` "no-sequence-number") >>= readM-  fields <- mapAlt structField $ elChildren el+  fields <- mapM structField $ elChildren el   guard $ not $ null fields   return $ XEvent name number fields noseq @@ -252,7 +258,7 @@ xerror el = do   name <- el `attr` "name"   number <- el `attr` "number" >>= readM-  fields <- mapAlt structField $ elChildren el+  fields <- mapM structField $ elChildren el   guard $ not $ null fields   return $ XError name number fields @@ -304,7 +310,7 @@   return $ XTypeDef newname oldtyp  -structField :: MonadPlus m => Element -> m StructElem+structField :: (MonadPlus m, Functor m) => Element -> m StructElem structField el     | el `named` "field" = do         typ <- liftM mkType $ el `attr` "type"@@ -331,6 +337,13 @@         list_name <- el `attr` "value-list-name"         return $ ValueParam mask_typ mask_name mask_pad list_name +    | el `named` "switch" = do+        nm <- el `attr` "name"+        (exprEl,caseEls) <- unconsChildren el+        expr <- expression exprEl+        cases <- mapM bitCase caseEls+        return $ Switch nm expr cases+     | el `named` "exprfield" = do         typ <- liftM mkType $ el `attr` "type"         name <- el `attr` "name"@@ -339,13 +352,44 @@      | el `named` "reply" = fail "" -- handled separate +    | el `named` "doc" = do+        fields <- el `children` "field"+        let mkField = \x -> fmap (\y -> (y, strContent x)) $ x `attr` "name"+            fields' = Map.fromList $ catMaybes $ map mkField fields+            sees = findChildren (unqual "see") el+            sees' = catMaybes $ flip map sees $ \s -> do typ <- s `attr` "type"+                                                         name <- s `attr` "name"+                                                         return (typ, name)+            brief = fmap strContent $ findChild (unqual "brief") el+        return $ Doc brief fields' sees'++    | el `named` "fd" = do+        name <- el `attr` "name"+        return $ Fd name+     | otherwise = let name = elName el                   in error $ "I don't know what to do with structelem "  ++ show name -expression :: MonadPlus m => Element -> m Expression+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+           | otherwise =+               let name = elName el+               in error $ "Invalid bitCase: " ++ show name++expression :: (MonadPlus m, Functor m) => Element -> m XExpression expression el | el `named` "fieldref"                     = return $ FieldRef $ strContent el+              | el `named` "enumref" = do+                   enumTy <- mkType <$> el `attr` "ref"+                   let enumVal = strContent el+                   guard $ enumVal /= ""+                   return $ EnumRef enumTy enumVal               | el `named` "value"                     = Value `liftM` readM (strContent el)               | el `named` "bit"@@ -357,8 +401,19 @@                     binop <- el `attr` "op" >>= toBinop                     [exprLhs,exprRhs] <- mapM expression $ elChildren el                     return $ Op binop exprLhs exprRhs-              | otherwise = do-                    error "Unknown epression name in Data.XCB.FromXML.expression"+              | el `named` "unop" = do+                    op <- el `attr` "op" >>= toUnop+                    expr <- firstChild el >>= expression+                    return $ Unop op expr+              | el `named` "popcount" = do+                    expr <- firstChild el >>= expression+                    return $ PopCount expr+              | el `named` "sumof" = do+                    ref <- el `attr` "ref"+                    return $ SumOf ref+              | otherwise =+                  let nm = elName el+                  in error $ "Unknown epression " ++ show nm ++ " in Data.XCB.FromXML.expression"   toBinop :: MonadPlus m => String -> m Binop@@ -371,7 +426,9 @@ toBinop ">>" = return RShift toBinop _ = mzero -+toUnop :: MonadPlus m => String -> m Unop+toUnop "~" = return Complement+toUnop _ = mzero   ----@@ -383,6 +440,12 @@ firstChild :: MonadPlus m => Element -> m Element firstChild = listToM . elChildren +unconsChildren :: MonadPlus m => Element -> m (Element, [Element])+unconsChildren el+    = case elChildren el of+        (x:xs) -> return (x,xs)+        _ -> mzero+ listToM :: MonadPlus m => [a] -> m a listToM [] = mzero listToM (x:_) = return x@@ -396,6 +459,13 @@       Just (Attr _ res) -> return res       _ -> mzero     where p (Attr qname _) | qname == unqual name = True+          p _ = False++children :: MonadPlus m => Element -> String -> m [Element]+(Element _ _ xs _) `children` name = case List.filter p xs of+      [] -> mzero+      some -> return $ onlyElems some+    where p (Elem (Element n _ _ _)) | n == unqual name = True           p _ = False  -- adapted from Network.CGI.Protocol

@@ -18,6 +18,7 @@  import Text.PrettyPrint.HughesPJ +import qualified Data.Map as Map import Data.Maybe  -- |Minimal complete definition:@@ -58,7 +59,10 @@     pretty RShift = ">>"     pretty And = "&" -instance Pretty EnumElem where+instance Pretty Unop where+    pretty Complement = "~"++instance Pretty a => Pretty (EnumElem a) where     toDoc (EnumElem name expr)         = text name <> char ':' <+> toDoc expr @@ -69,15 +73,23 @@  -- More complex stuff -instance Pretty Expression where+instance Pretty a => Pretty (Expression a) where     toDoc (Value n) = toDoc n     toDoc (Bit n) = text "2^" <> toDoc n     toDoc (FieldRef ref) = char '$' <> text ref+    toDoc (EnumRef typ child)+        = toDoc typ <> char '.' <> text child+    toDoc (PopCount expr)+        = text "popcount" <> parens (toDoc expr)+    toDoc (SumOf ref)+        = text "sumof" <> (parens $ char '$' <> text ref)     toDoc (Op binop exprL exprR)         = parens $ hsep [toDoc exprL                         ,toDoc binop                         ,toDoc exprR                         ]+    toDoc (Unop op expr)+        = parens $ toDoc op <> toDoc expr  instance Pretty a => Pretty (GenStructElem a) where     toDoc (Pad n) = braces $ toDoc n <+> text "bytes"@@ -90,8 +102,30 @@                                             ,toDoc mask                                             ]     toDoc (ExprField nm typ expr)-          = parens (text nm <+> text "::" <+> toDoc typ)-            <+> toDoc expr+        = parens (text nm <+> text "::" <+> toDoc typ)+          <+> toDoc expr+    toDoc (Switch name expr cases)+        = vcat+           [ text "switch" <> parens (toDoc expr) <> brackets (text name)+           , braces (vcat (map toDoc cases))+           ]+    toDoc (Doc brief fields see)+        = text "Doc" <+>+          text "::" <+>+          text "brief=" <+> text (fromMaybe "" brief) <+>+          text "fields=" <+>+          hsep (punctuate (char ',') $ joinWith ":" $ Map.toList fields) <+>+          text ";" <+>+          text "see=" <+>+          hsep (punctuate (char ',') $ joinWith "." see)++        where+          joinWith c = map $ \(x,y) -> text $ x ++ c ++ y++    toDoc (Fd fd)+        = text "Fd" <+>+          text "::" <+>+          text fd     toDoc (ValueParam typ mname mpad lname)         = text "Valueparam" <+>           text "::" <+>@@ -109,6 +143,19 @@                       ,text mname                       ,text lname                       ]++instance Pretty a => Pretty (GenBitCase a) where+    toDoc (BitCase name expr fields)+        = vcat+           [ bitCaseHeader name expr+           , braces (vcat (map toDoc fields))+           ]++bitCaseHeader :: Pretty a => Maybe Name -> Expression a -> Doc+bitCaseHeader Nothing expr =+    text "bitcase" <> parens (toDoc expr)+bitCaseHeader (Just name) expr =+    text "bitcase" <> parens (toDoc expr) <> brackets (text name)  instance Pretty a => Pretty (GenXDecl a) where     toDoc (XStruct nm elems) =

@@ -1,5 +1,6 @@ {-# LANGUAGE-     RecordWildCards+     RecordWildCards,+     DeriveFunctor      #-}  -- |@@ -20,16 +21,21 @@     ( XHeader     , XDecl     , StructElem+    , XEnumElem+    , BitCase     , XidUnionElem     , XReply+    , XExpression     , GenXHeader ( .. )     , GenXDecl ( .. )     , GenStructElem ( .. )+    , GenBitCase ( .. )     , GenXReply     , GenXidUnionElem ( .. )     , EnumElem ( .. )     , Expression ( .. )     , Binop ( .. )+    , Unop ( .. )     , Type ( .. )     , EnumVals     , MaskVals@@ -40,8 +46,7 @@     , MaskPadding     ) where --import Control.Monad+import Data.Map  -- 'xheader_header' is the name gauranteed to exist, and is used in -- imports and in type qualifiers.@@ -59,27 +64,16 @@     ,xheader_minor_version :: Maybe Int     ,xheader_decls :: [GenXDecl typ]  -- ^Declarations contained in this module.     }- deriving (Show)--instance Functor GenXHeader where-    fmap = mapTypes--mapTypes :: (a -> b) -> GenXHeader a -> GenXHeader b-mapTypes f XHeader{..} =-    XHeader-     xheader_header-     xheader_xname-     xheader_name-     xheader_multiword-     xheader_major_version-     xheader_minor_version-     (map (mapDecls f) xheader_decls)+ deriving (Show, Functor)  type XHeader = GenXHeader Type type XDecl = GenXDecl Type type StructElem = GenStructElem Type+type BitCase = GenBitCase Type type XidUnionElem = GenXidUnionElem Type type XReply = GenXReply Type+type XExpression = Expression Type+type XEnumElem = EnumElem Type  -- |The different types of declarations which can be made in one of the -- XML files.@@ -90,53 +84,26 @@     | XRequest Name Int [GenStructElem typ] (Maybe (GenXReply typ))     | XidType  Name     | XidUnion  Name [GenXidUnionElem typ]-    | XEnum Name [EnumElem]+    | XEnum Name [EnumElem typ]     | XUnion Name [GenStructElem typ]     | XImport Name     | XError Name Int [GenStructElem typ]- deriving (Show)--instance Functor GenXDecl where-    fmap = mapDecls--mapDecls :: (a -> b) -> GenXDecl a -> GenXDecl b-mapDecls f = go- where-   go (XStruct name elems) = XStruct name (map (mapSElem f) elems)-   go (XTypeDef name t) = XTypeDef name (f t)-   go (XEvent name n elems seqNum)-       = XEvent name n (map (mapSElem f) elems) seqNum-   go (XRequest name n elems rep) = XRequest name n (map (mapSElem f) elems) (mapReply f rep)-   go (XidType name) = XidType name-   go (XEnum name elems) = XEnum name elems-   go (XUnion name elems) = XUnion name (map (mapSElem f) elems)-   go (XidUnion name elems) = XidUnion name (map (mapUnions f) elems)-   go (XImport name) = XImport name-   go (XError name n elems) = XError name n (map (mapSElem f) elems)--mapReply :: Functor f =>-            (typ -> typ') -> f [GenStructElem typ] -> f [GenStructElem typ']-mapReply f = fmap (map (mapSElem f))+ deriving (Show, Functor)  data GenStructElem typ     = Pad Int-    | List Name typ (Maybe Expression) (Maybe (EnumVals typ))+    | List Name typ (Maybe (Expression typ)) (Maybe (EnumVals typ))     | SField Name typ (Maybe (EnumVals typ)) (Maybe (MaskVals typ))-    | ExprField Name typ Expression+    | ExprField Name typ (Expression typ)     | ValueParam typ Name (Maybe MaskPadding) ListName- deriving (Show)--instance Functor GenStructElem where-    fmap = mapSElem+    | Switch Name (Expression typ) [GenBitCase typ]+    | Doc (Maybe String) (Map Name String) [(String, String)]+    | Fd String+ deriving (Show, Functor) -mapSElem :: (typ -> typ') -> GenStructElem typ -> GenStructElem typ'-mapSElem f = go- where-   go (Pad n) = Pad n-   go (List name typ expr enum) = List name (f typ) expr (liftM f enum)-   go (SField name typ enum mask) = SField name (f typ) (liftM f enum) (liftM f mask)-   go (ExprField name typ expr) = ExprField name (f typ) expr-   go (ValueParam typ name pad lname) = ValueParam (f typ) name pad lname+data GenBitCase typ+    = BitCase (Maybe Name) (Expression typ) [GenStructElem typ]+ deriving (Show, Functor)  type EnumVals typ = typ type MaskVals typ = typ@@ -151,27 +118,26 @@ -- |Types may include a reference to the containing module. data Type = UnQualType Name           | QualType Name Name- deriving Show+ deriving (Show, Eq, Ord)  data GenXidUnionElem typ = XidUnionElem typ- deriving (Show)--instance Functor GenXidUnionElem where-    fmap = mapUnions--mapUnions :: (typ -> typ') -> GenXidUnionElem typ -> GenXidUnionElem typ'-mapUnions f (XidUnionElem t) = XidUnionElem (f t)+ deriving (Show, Functor)  -- Should only ever have expressions of type 'Value' or 'Bit'.-data EnumElem = EnumElem Name (Maybe Expression)- deriving (Show)+data EnumElem typ = EnumElem Name (Maybe (Expression typ))+ deriving (Show, Functor)  -- |Declarations may contain expressions from this small language-data Expression = Value Int  -- ^A literal value-                | Bit Int    -- ^A log-base-2 literal value-                | FieldRef Name -- ^A reference to a field in the same declaration-                | Op Binop Expression Expression -- ^A binary opeation- deriving (Show)+data Expression typ+    = Value Int  -- ^A literal value+    | Bit Int    -- ^A log-base-2 literal value+    | FieldRef Name -- ^A reference to a field in the same declaration+    | EnumRef typ Name -- ^A reference to a member of an enum.+    | PopCount (Expression typ) -- ^Calculate the number of set bits in the argument+    | 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+ deriving (Show, Functor)  -- |Supported Binary operations. data Binop = Add@@ -182,3 +148,5 @@            | RShift  deriving (Show) +data Unop = Complement+ deriving (Show)

@@ -1,5 +1,5 @@ Name:         xcb-types-Version:      0.6.3+Version:      0.7.0 Cabal-Version:  >= 1.6 Synopsis:     Parses XML files used by the XCB project Description:   This package provides types which mirror the structures@@ -30,7 +30,11 @@  Library - Build-depends: base == 4.*, xml == 1.3.*, pretty == 1.0.* || == 1.1.*, mtl == 2.0.* || == 2.1.*+ Build-depends: base == 4.*,+                xml == 1.3.*,+                pretty == 1.0.* || == 1.1.*,+                mtl >= 2.0 && < 2.3,+                containers >= 0.5  Exposed-modules: Data.XCB,                   Data.XCB.Types,                   Data.XCB.Pretty,