diff --git a/Data/XCB/FromXML.hs b/Data/XCB/FromXML.hs --- a/Data/XCB/FromXML.hs +++ b/Data/XCB/FromXML.hs @@ -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 diff --git a/Data/XCB/Pretty.hs b/Data/XCB/Pretty.hs --- a/Data/XCB/Pretty.hs +++ b/Data/XCB/Pretty.hs @@ -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) = diff --git a/Data/XCB/Types.hs b/Data/XCB/Types.hs --- a/Data/XCB/Types.hs +++ b/Data/XCB/Types.hs @@ -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) diff --git a/xcb-types.cabal b/xcb-types.cabal --- a/xcb-types.cabal +++ b/xcb-types.cabal @@ -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,