xcb-types-0.14.0/0000755000000000000000000000000007346545000011703 5ustar0000000000000000xcb-types-0.14.0/Data/0000755000000000000000000000000007346545000012554 5ustar0000000000000000xcb-types-0.14.0/Data/XCB.hs0000644000000000000000000000116407346545000013526 0ustar0000000000000000-- | -- Module : Data.XCB -- Copyright : (c) Antoine Latter 2008 -- License : BSD3 -- -- Maintainer: Antoine Latter -- Stability : provisional -- Portability: portable -- -- The 'Data.XCB' module can parse the contents of the xcb-proto -- XML files into Haskell data structures. -- -- Pretty-printers are provided to aid in the debugging - they do -- not pretty-print to XML, but to a custom human-readable format. module Data.XCB (module Data.XCB.Types ,module Data.XCB.FromXML ,module Data.XCB.Pretty ) where import Data.XCB.Types import Data.XCB.FromXML import Data.XCB.Pretty xcb-types-0.14.0/Data/XCB/0000755000000000000000000000000007346545000013170 5ustar0000000000000000xcb-types-0.14.0/Data/XCB/FromXML.hs0000644000000000000000000004325007346545000015014 0ustar0000000000000000-- | -- Module : Data.XCB.FromXML -- Copyright : (c) Antoine Latter 2008 -- License : BSD3 -- -- Maintainer: Antoine Latter -- Stability : provisional -- Portability: portable -- -- Handls parsing the data structures from XML files. -- -- In order to support copying events and errors across module -- boundaries, all modules which may have cross-module event copies and -- error copies must be parsed at once. -- -- There is no provision for preserving the event copy and error copy -- declarations - the copies are handled during parsing. {-# LANGUAGE CPP #-} module Data.XCB.FromXML(fromFiles ,fromStrings ) where import Data.XCB.Types import Data.XCB.Utils import Text.XML.Light import Data.List as List import qualified Data.Map as Map import Data.Maybe (catMaybes, mapMaybe, maybeToList) import Control.Monad (MonadPlus (mzero, mplus), guard, liftM, liftM2) import Control.Monad.Reader (ReaderT, runReaderT, ask, lift, withReaderT) #if __GLASGOW_HASKELL__ < 900 import Control.Monad.Fail (MonadFail) #endif import System.IO (openFile, IOMode (ReadMode), hSetEncoding, utf8, hGetContents) -- |Process the listed XML files. -- Any files which fail to parse are silently dropped. -- Any declaration in an XML file which fail to parse are -- silently dropped. fromFiles :: [FilePath] -> IO [XHeader] fromFiles xs = do 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 hSetEncoding h utf8 hGetContents h -- |Process the strings as if they were XML files. -- Any files which fail to parse are silently dropped. -- Any declaration in an XML file which fail to parse are -- silently dropped. fromStrings :: [String] -> [XHeader] fromStrings xs = let rs = mapAlt fromString xs headers = concat $ maybeToList $ runReaderT rs headers in headers -- The 'Parse' monad. Provides the name of the -- current module, and a list of all of the modules. type Parse = ReaderT ([XHeader],Name) Maybe -- operations in the 'Parse' monad localName :: Parse Name 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. -- -- this implements searching both the current module and -- the xproto module if the name is not specified. lookupThingy :: ([XDecl] -> Maybe a) -> (Maybe Name) -> Parse (Maybe a) lookupThingy f Nothing = do lname <- localName liftM2 mplus (lookupThingy f $ Just lname) (lookupThingy f $ Just "xproto") -- implicit xproto import lookupThingy f (Just mname) = do xs <- allModules return $ do x <- findXHeader mname xs f $ xheader_decls x -- lookup an event declaration by name. lookupEvent :: Maybe Name -> Name -> Parse (Maybe EventDetails) lookupEvent mname evname = flip lookupThingy mname $ \decls -> findEvent evname decls -- lookup an error declaration by name. lookupError :: Maybe Name -> Name -> Parse (Maybe ErrorDetails) lookupError mname ername = flip lookupThingy mname $ \decls -> findError ername decls findXHeader :: Name -> [XHeader] -> Maybe XHeader findXHeader name = List.find $ \ x -> xheader_header x == name findError :: Name -> [XDecl] -> Maybe ErrorDetails findError pname xs = case List.find f xs of Nothing -> Nothing 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 f _ = False findEvent :: Name -> [XDecl] -> Maybe EventDetails findEvent pname xs = case List.find f xs of Nothing -> Nothing Just (XEvent name code alignment xge elems noseq) -> Just $ EventDetails name code alignment xge elems noseq _ -> error "impossible: fatal error in Data.XCB.FromXML.findEvent" where f (XEvent name _ _ _ _ _) | name == pname = True f _ = False data EventDetails = EventDetails Name Int (Maybe Alignment) (Maybe Bool) [StructElem] (Maybe Bool) data ErrorDetails = ErrorDetails Name Int (Maybe Alignment) [StructElem] --- -- extract a single XHeader from a single XML document fromString :: String -> ReaderT [XHeader] Maybe XHeader fromString str = do el@(Element _qname _ats cnt _) <- lift $ parseXMLDoc str guard $ el `named` "xcb" header <- el `attr` "header" let name = el `attr` "extension-name" xname = el `attr` "extension-xname" maj_ver = el `attr` "major-version" >>= readM min_ver = el `attr` "minor-version" >>= readM multiword = el `attr` "extension-multiword" >>= readM . ensureUpper decls <- withReaderT (\r -> (r,header)) $ extractDecls cnt return $ XHeader {xheader_header = header ,xheader_xname = xname ,xheader_name = name ,xheader_multiword = multiword ,xheader_major_version = maj_ver ,xheader_minor_version = min_ver ,xheader_decls = decls } -- attempts to extract declarations from XML content, discarding failures. extractDecls :: [Content] -> Parse [XDecl] extractDecls = mapAlt declFromElem . onlyElems -- attempt to extract a module declaration from an XML element declFromElem :: Element -> Parse XDecl declFromElem el | el `named` "request" = xrequest el | el `named` "event" = xevent el | el `named` "eventcopy" = xevcopy el | el `named` "error" = xerror el | el `named` "errorcopy" = xercopy el | el `named` "struct" = xstruct el | el `named` "union" = xunion el | el `named` "xidtype" = xidtype el | el `named` "xidunion" = xidunion el | el `named` "typedef" = xtypedef el | el `named` "enum" = xenum el | el `named` "import" = ximport el | el `named` "eventstruct" = xeventstruct el | otherwise = mzero ximport :: Element -> Parse XDecl ximport = return . XImport . strContent xenum :: Element -> Parse XDecl xenum el = do nm <- el `attr` "name" fields <- mapAlt enumField $ elChildren el guard $ not $ null fields return $ XEnum nm fields enumField :: Element -> Parse (EnumElem Type) enumField el = do guard $ el `named` "item" name <- el `attr` "name" let expr = firstChild el >>= expression return $ EnumElem name expr xrequest :: Element -> Parse XDecl 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 (alignment, xs) <- extractAlignment $ elChildren el fields <- mapAlt structField $ xs let reply = getReply el return $ XRequest nm code alignment fields reply getReply :: Element -> Maybe XReply getReply el = do childElem <- unqual "reply" `findChild` el (alignment, xs) <- extractAlignment $ elChildren childElem fields <- mapM structField xs guard $ not $ null fields return $ GenXReply alignment fields xevent :: Element -> Parse XDecl xevent el = do name <- el `attr` "name" number <- el `attr` "number" >>= readM let xge = ensureUpper `liftM` (el `attr` "xge") >>= readM let noseq = ensureUpper `liftM` (el `attr` "no-sequence-number") >>= readM (alignment, xs) <- extractAlignment (elChildren el) fields <- mapM structField $ xs guard $ not $ null fields return $ XEvent name number alignment xge fields noseq xevcopy :: Element -> Parse XDecl xevcopy el = do name <- el `attr` "name" number <- el `attr` "number" >>= readM ref <- el `attr` "ref" -- do we have a qualified ref? let (mname,evname) = splitRef ref details <- lookupEvent mname evname return $ let EventDetails _ _ alignment xge fields noseq = case details of Nothing -> error $ "Unresolved event: " ++ show mname ++ " " ++ ref Just x -> x in XEvent name number alignment xge fields noseq -- we need to do string processing to distinguish qualified from -- unqualified types. mkType :: String -> Type mkType str = let (mname, name) = splitRef str in case mname of Just modifier -> QualType modifier name Nothing -> UnQualType name splitRef :: Name -> (Maybe Name, Name) splitRef ref = case split ':' ref of (x,"") -> (Nothing, x) (a, b) -> (Just a, b) -- |Neither returned string contains the first occurance of the -- supplied Char. split :: Char -> String -> (String, String) split c = go where go [] = ([],[]) go (x:xs) | x == c = ([],xs) | otherwise = let (lefts, rights) = go xs in (x:lefts,rights) xerror :: Element -> Parse XDecl xerror el = do name <- el `attr` "name" number <- el `attr` "number" >>= readM (alignment, xs) <- extractAlignment $ elChildren el fields <- mapM structField $ xs return $ XError name number alignment fields xercopy :: Element -> Parse XDecl xercopy el = do name <- el `attr` "name" number <- el `attr` "number" >>= readM ref <- el `attr` "ref" let (mname, ername) = splitRef ref details <- lookupError mname ername return $ uncurry (XError name number) $ case details of Nothing -> error $ "Unresolved error: " ++ show mname ++ " " ++ ref Just (ErrorDetails _ _ alignment elems) -> (alignment, elems) xstruct :: Element -> Parse XDecl xstruct el = do name <- el `attr` "name" (alignment, xs) <- extractAlignment $ elChildren el fields <- mapAlt structField $ xs guard $ not $ null fields return $ XStruct name alignment fields xunion :: Element -> Parse XDecl xunion el = do name <- el `attr` "name" (alignment, xs) <- extractAlignment $ elChildren el fields <- mapAlt structField $ xs guard $ not $ null fields return $ XUnion name alignment fields xidtype :: Element -> Parse XDecl xidtype el = liftM XidType $ el `attr` "name" xidunion :: Element -> Parse XDecl xidunion el = do name <- el `attr` "name" let types = mapMaybe xidUnionElem $ elChildren el guard $ not $ null types return $ XidUnion name types xidUnionElem :: Element -> Maybe XidUnionElem xidUnionElem el = do guard $ el `named` "type" return $ XidUnionElem $ mkType $ strContent el xtypedef :: Element -> Parse XDecl xtypedef el = do oldtyp <- liftM mkType $ el `attr` "oldname" newname <- el `attr` "newname" return $ XTypeDef newname oldtyp xeventstruct :: Element -> Parse XDecl xeventstruct el = do name <- el `attr` "name" allowed <- mapAlt allowedEvent $ elChildren el return $ XEventStruct name allowed allowedEvent :: (MonadPlus m, Functor m) => Element -> m AllowedEvent allowedEvent el = do extension <- el `attr` "name" xge <- el `attr` "xge" >>= readM opMin <- el `attr` "opcode-min" >>= readM opMax <- el `attr` "opcode-max" >>= readM return $ AllowedEvent extension xge opMin opMax structField :: (MonadFail m, MonadPlus m, Functor m) => Element -> m StructElem structField el | el `named` "field" = do typ <- liftM mkType $ el `attr` "type" let enum = liftM mkType $ el `attr` "enum" let mask = liftM mkType $ el `attr` "mask" name <- el `attr` "name" return $ SField name typ enum mask | el `named` "pad" = do let bytes = liftM (Pad PadBytes) $ el `attr` "bytes" >>= readM let align = liftM (Pad PadAlignment) $ el `attr` "align" >>= readM return $ head $ catMaybes $ [bytes, align] | el `named` "list" = do typ <- liftM mkType $ el `attr` "type" name <- el `attr` "name" let enum = liftM mkType $ el `attr` "enum" let expr = firstChild el >>= expression return $ List name typ expr enum | el `named` "valueparam" = do mask_typ <- liftM mkType $ el `attr` "value-mask-type" mask_name <- el `attr` "value-mask-name" let mask_pad = el `attr` "value-mask-pad" >>= readM 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 (alignment, xs) <- extractAlignment $ caseEls cases <- mapM bitCase xs return $ Switch nm expr alignment cases | el `named` "exprfield" = do typ <- liftM mkType $ el `attr` "type" name <- el `attr` "name" expr <- firstChild el >>= expression return $ ExprField name typ expr | 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 | el `named` "length" = do expr <- firstChild el >>= expression let typ = mkType "CARD32" return $ Length typ expr | otherwise = let name = elName el in error $ "I don't know what to do with structelem " ++ show name bitCase :: (MonadFail m, MonadPlus m, Functor m) => Element -> m BitCase 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 expression :: (MonadFail m, 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" = Bit `liftM` do n <- readM (strContent el) guard $ n >= 0 return n | el `named` "op" = do binop <- el `attr` "op" >>= toBinop [exprLhs,exprRhs] <- mapM expression $ elChildren el return $ Op binop exprLhs exprRhs | 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 | el `named` "paramref" = return $ ParamRef $ strContent el | otherwise = let nm = elName el in error $ "Unknown epression " ++ show nm ++ " in Data.XCB.FromXML.expression" toBinop :: MonadPlus m => String -> m Binop toBinop "+" = return Add toBinop "-" = return Sub toBinop "*" = return Mult toBinop "/" = return Div toBinop "&" = return And toBinop "&" = return And toBinop ">>" = return RShift toBinop _ = mzero toUnop :: MonadPlus m => String -> m Unop toUnop "~" = return Complement toUnop _ = mzero ---- ---- -- Utility functions ---- ---- 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 named :: Element -> String -> Bool named (Element qname _ _ _) name | qname == unqual name = True named _ _ = False attr :: MonadPlus m => Element -> String -> m String (Element _ xs _ _) `attr` name = case List.find p xs of 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 readM :: (MonadPlus m, Read a) => String -> m a readM = liftM fst . listToM . reads xcb-types-0.14.0/Data/XCB/Pretty.hs0000644000000000000000000001716207346545000015022 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -- | -- Module : Data.XCB.Pretty -- Copyright : (c) Antoine Latter 2008 -- License : BSD3 -- -- Maintainer: Antoine Latter -- Stability : provisional -- Portability: portable - requires TypeSynonymInstances -- -- Pretty-printers for the tyes declared in this package. -- This does NOT ouput XML - it produces human-readable information -- intended to aid in debugging. module Data.XCB.Pretty where import Prelude hiding ((<>)) import Data.XCB.Types import Text.PrettyPrint.HughesPJ import qualified Data.Map as Map import Data.Maybe -- |Minimal complete definition: -- -- One of 'pretty' or 'toDoc'. class Pretty a where toDoc :: a -> Doc pretty :: a -> String pretty = show . toDoc toDoc = text . pretty -- Builtin types instance Pretty String where pretty = show instance Pretty Int where pretty = show instance Pretty Bool where pretty = show instance Pretty a => Pretty (Maybe a) where toDoc Nothing = empty toDoc (Just a) = toDoc a pretty Nothing = "" pretty (Just a) = pretty a -- Simple stuff instance Pretty a => Pretty (GenXidUnionElem a) where toDoc (XidUnionElem t) = toDoc t instance Pretty Binop where pretty Add = "+" pretty Sub = "-" pretty Mult = "*" pretty Div = "/" pretty RShift = ">>" pretty And = "&" instance Pretty Unop where pretty Complement = "~" instance Pretty a => Pretty (EnumElem a) where toDoc (EnumElem name expr) = text name <> char ':' <+> toDoc expr instance Pretty Type where toDoc (UnQualType name) = text name toDoc (QualType modifier name) = text modifier <> char '.' <> text name -- More complex stuff 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 toDoc (ParamRef n) = toDoc n instance Pretty PadType where pretty PadBytes = "bytes" pretty PadAlignment = "align" instance Pretty a => Pretty (GenStructElem a) where toDoc (Pad typ n) = braces $ toDoc n <+> toDoc typ toDoc (List nm typ len enums) = text nm <+> text "::" <+> brackets (toDoc typ <+> toDoc enums) <+> toDoc len toDoc (SField nm typ enums mask) = hsep [text nm ,text "::" ,toDoc typ ,toDoc enums ,toDoc mask ] toDoc (ExprField nm typ expr) = parens (text nm <+> text "::" <+> toDoc typ) <+> toDoc expr toDoc (Switch name expr alignment cases) = vcat [ text "switch" <> parens (toDoc expr) <> toDoc alignment <> 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 "::" <+> hsep (punctuate (char ',') details) where details | isJust mpad = [toDoc typ ,text "mask padding:" <+> toDoc mpad ,text mname ,text lname ] | otherwise = [toDoc typ ,text mname ,text lname ] toDoc (Length _ expr) = text "length" <+> parens (toDoc expr) instance Pretty a => Pretty (GenBitCase a) where toDoc (BitCase name expr alignment fields) = vcat [ bitCaseHeader name expr , toDoc alignment , 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 Alignment where toDoc (Alignment align offset) = text "alignment" <+> text "align=" <+> toDoc align <+> text "offset=" <+> toDoc offset instance Pretty AllowedEvent where toDoc (AllowedEvent extension xge opMin opMax) = text "allowed" <+> text "extension=" <+> text extension <+> text "xge=" <> toDoc xge <> text "opcode-min" <> toDoc opMin <> text "opcode-max" <> toDoc opMax instance Pretty a => Pretty (GenXDecl a) where 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 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 alignment _ elems _) = hang (text "Event:" <+> text nm <> char ',' <> toDoc n <+> toDoc alignment) 2 $ vcat $ map toDoc elems 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 (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) = hang (text "XID" <+> text "Union:" <+> text nm) 2 $ vcat $ map toDoc elems toDoc (XEnum nm elems) = hang (text "Enum:" <+> 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 alignment elems) = hang (text "Error:" <+> text nm <+> toDoc alignment) 2 $ vcat $ map toDoc elems toDoc (XEventStruct name allowed) = hang (text "Event struct:" <+> text name) 2 $ vcat $ map toDoc allowed instance Pretty a => Pretty (GenXHeader a) where toDoc xhd = text (xheader_header xhd) $$ (vcat $ map toDoc (xheader_decls xhd)) xcb-types-0.14.0/Data/XCB/Types.hs0000644000000000000000000001207207346545000014632 0ustar0000000000000000{-# LANGUAGE RecordWildCards, DeriveFunctor #-} -- | -- Module : Data.XCB.Types -- Copyright : (c) Antoine Latter 2008 -- License : BSD3 -- -- Maintainer: Antoine Latter -- Stability : provisional -- Portability: portable -- -- Defines types inteneded to be equivalent to the schema used by -- the XCB project in their XML protocol description. -- module Data.XCB.Types ( XHeader , XDecl , StructElem , XEnumElem , BitCase , XidUnionElem , XReply , XExpression , GenXHeader ( .. ) , GenXDecl ( .. ) , GenStructElem ( .. ) , GenBitCase ( .. ) , GenXReply ( .. ) , GenXidUnionElem ( .. ) , EnumElem ( .. ) , Expression ( .. ) , Binop ( .. ) , Unop ( .. ) , Type ( .. ) , EnumVals , MaskVals , Name , Ref , MaskName , ListName , MaskPadding , Alignment ( .. ) , AllowedEvent ( .. ) , PadType ( .. ) ) where import Data.Map -- 'xheader_header' is the name gauranteed to exist, and is used in -- imports and in type qualifiers. -- -- 'xheader_name' is the InterCaps name, and should be prefered in the naming -- of types, functions and haskell modules when available. -- |This is what a single XML file maps to. It contains some meta-data -- then declarations. data GenXHeader typ = XHeader {xheader_header :: Name -- ^Name of module. Used in the other modules as a reference. ,xheader_xname :: Maybe Name -- ^Name used to indentify extensions between the X client and server. ,xheader_name :: Maybe Name -- ^InterCaps name. ,xheader_multiword :: Maybe Bool ,xheader_major_version :: Maybe Int ,xheader_minor_version :: Maybe Int ,xheader_decls :: [GenXDecl typ] -- ^Declarations contained in this module. } 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. data GenXDecl typ = XStruct Name (Maybe Alignment) [GenStructElem typ] | XTypeDef Name typ | XEvent Name Int (Maybe Alignment) (Maybe Bool) [GenStructElem typ] (Maybe Bool) -- ^ bools: #1 if xge is true; #2 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 (Maybe Alignment) [GenStructElem typ] | XImport Name | XError Name Int (Maybe Alignment) [GenStructElem typ] | XEventStruct Name [AllowedEvent] deriving (Show, Functor) data PadType = PadBytes | PadAlignment deriving (Show) data GenStructElem typ = Pad PadType Int | List Name typ (Maybe (Expression typ)) (Maybe (EnumVals 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) (Maybe Alignment) [GenBitCase typ] | Doc (Maybe String) (Map Name String) [(String, String)] | Fd String | Length typ (Expression typ) deriving (Show, Functor) data GenBitCase typ = BitCase (Maybe Name) (Expression typ) (Maybe Alignment) [GenStructElem typ] deriving (Show, Functor) type EnumVals typ = typ type MaskVals typ = typ type Name = String data GenXReply typ = GenXReply (Maybe Alignment) [GenStructElem typ] deriving (Show, Functor) type Ref = String type MaskName = Name type ListName = Name type MaskPadding = Int -- |Types may include a reference to the containing module. data Type = UnQualType Name | QualType Name Name deriving (Show, Eq, Ord) data GenXidUnionElem typ = XidUnionElem typ deriving (Show, Functor) -- Should only ever have expressions of type 'Value' or 'Bit'. data EnumElem typ = EnumElem Name (Maybe (Expression typ)) deriving (Show, Functor) -- |Declarations may contain expressions from this small language 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 | 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. data Binop = Add | Sub | Mult | Div | And | RShift deriving (Show) data Unop = Complement deriving (Show) data Alignment = Alignment Int Int deriving (Show) data AllowedEvent = AllowedEvent Name Bool Int Int deriving (Show) xcb-types-0.14.0/Data/XCB/Utils.hs0000644000000000000000000000071207346545000014624 0ustar0000000000000000module Data.XCB.Utils where -- random utility functions import Data.Char import Control.Applicative ensureUpper :: String -> String ensureUpper [] = [] ensureUpper (x:xs) = (toUpper x) : xs -- |Like mapMaybe, but for any Alternative. -- Never returns 'empty', instead returns 'pure []' mapAlt :: Alternative f => (a -> f b) -> [a] -> f [b] mapAlt f xs = go xs where go [] = pure [] go (y:ys) = pure (:) <*> f y <*> go ys <|> go ys xcb-types-0.14.0/LICENSE0000644000000000000000000000276307346545000012720 0ustar0000000000000000Copyright Antoine Latter 2008, 2009 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the author nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. xcb-types-0.14.0/Setup.hs0000644000000000000000000000005607346545000013340 0ustar0000000000000000import Distribution.Simple main = defaultMain xcb-types-0.14.0/xcb-types.cabal0000644000000000000000000000257607346545000014617 0ustar0000000000000000Name: xcb-types Version: 0.14.0 Cabal-Version: >= 1.10 Synopsis: Parses XML files used by the XCB project Description: This package provides types which mirror the structures used in the XCB code generation XML files. . See project http://xcb.freedesktop.org/ for more information about the XCB project. . The XML files describe the data-types, events and requests used by the X Protocol, and are used to auto-generate large parts of the XCB project. . This package parses these XML files into Haskell data structures. . If you want to do something with these XML descriptions but don't want to learn XSLT, this package should help. . This version of xcb-types is intended to fully parse the X Protocol description version 1.16. License: BSD3 License-file: LICENSE Author: Antoine Latter Maintainer: Antoine Latter Homepage: http://community.haskell.org/~aslatter/code/xcb-types Build-type: Simple Category: Data Library Build-depends: base == 4.*, xml == 1.3.*, pretty == 1.0.* || == 1.1.*, mtl >= 2.0 && < 2.4, containers >= 0.5 Exposed-modules: Data.XCB, Data.XCB.Types, Data.XCB.Pretty, Data.XCB.FromXML Other-modules: Data.XCB.Utils Default-Language: Haskell2010 Ghc-Options: -Wall