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)
import System.IO (openFile, IOMode (ReadMode), hSetEncoding, utf8, hGetContents)
fromFiles :: [FilePath] -> IO [XHeader]
fromFiles :: [Name] -> IO [XHeader]
fromFiles [Name]
xs = do
[Name]
strings <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> IO Name
readFileUTF8 [Name]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Name] -> [XHeader]
fromStrings [Name]
strings
readFileUTF8 :: FilePath -> IO String
readFileUTF8 :: Name -> IO Name
readFileUTF8 Name
fp = do
Handle
h <- Name -> IOMode -> IO Handle
openFile Name
fp IOMode
ReadMode
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
Handle -> IO Name
hGetContents Handle
h
fromStrings :: [String] -> [XHeader]
fromStrings :: [Name] -> [XHeader]
fromStrings [Name]
xs =
let rs :: ReaderT [XHeader] Maybe [XHeader]
rs = forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Name -> ReaderT [XHeader] Maybe XHeader
fromString [Name]
xs
headers :: [XHeader]
headers = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT [XHeader] Maybe [XHeader]
rs [XHeader]
headers
in [XHeader]
headers
type Parse = ReaderT ([XHeader],Name) Maybe
localName :: Parse Name
localName :: Parse Name
localName = forall a b. (a, b) -> b
snd forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall r (m :: * -> *). MonadReader r m => m r
ask
allModules :: Parse [XHeader]
allModules :: Parse [XHeader]
allModules = forall a b. (a, b) -> a
fst forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall r (m :: * -> *). MonadReader r m => m r
ask
extractAlignment :: (MonadPlus m, Functor m) => [Element] -> m (Maybe Alignment, [Element])
(Element
el : [Element]
xs) | Element
el Element -> Name -> Bool
`named` Name
"required_start_align" = do
Int
align <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"align" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
Int
offset <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"offset" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Int -> Int -> Alignment
Alignment Int
align Int
offset), [Element]
xs)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, Element
el forall a. a -> [a] -> [a]
: [Element]
xs)
extractAlignment [Element]
xs = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [Element]
xs)
lookupThingy :: ([XDecl] -> Maybe a)
-> (Maybe Name)
-> Parse (Maybe a)
lookupThingy :: forall a. ([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
lookupThingy [XDecl] -> Maybe a
f Maybe Name
Nothing = do
Name
lname <- Parse Name
localName
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (forall a. ([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
lookupThingy [XDecl] -> Maybe a
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Name
lname)
(forall a. ([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
lookupThingy [XDecl] -> Maybe a
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Name
"xproto")
lookupThingy [XDecl] -> Maybe a
f (Just Name
mname) = do
[XHeader]
xs <- Parse [XHeader]
allModules
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
XHeader
x <- Name -> [XHeader] -> Maybe XHeader
findXHeader Name
mname [XHeader]
xs
[XDecl] -> Maybe a
f forall a b. (a -> b) -> a -> b
$ forall typ. GenXHeader typ -> [GenXDecl typ]
xheader_decls XHeader
x
lookupEvent :: Maybe Name -> Name -> Parse (Maybe EventDetails)
lookupEvent :: Maybe Name -> Name -> Parse (Maybe EventDetails)
lookupEvent Maybe Name
mname Name
evname = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. ([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
lookupThingy Maybe Name
mname forall a b. (a -> b) -> a -> b
$ \[XDecl]
decls ->
Name -> [XDecl] -> Maybe EventDetails
findEvent Name
evname [XDecl]
decls
lookupError :: Maybe Name -> Name -> Parse (Maybe ErrorDetails)
lookupError :: Maybe Name -> Name -> Parse (Maybe ErrorDetails)
lookupError Maybe Name
mname Name
ername = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. ([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
lookupThingy Maybe Name
mname forall a b. (a -> b) -> a -> b
$ \[XDecl]
decls ->
Name -> [XDecl] -> Maybe ErrorDetails
findError Name
ername [XDecl]
decls
findXHeader :: Name -> [XHeader] -> Maybe XHeader
Name
name = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find forall a b. (a -> b) -> a -> b
$ \ XHeader
x -> forall typ. GenXHeader typ -> Name
xheader_header XHeader
x forall a. Eq a => a -> a -> Bool
== Name
name
findError :: Name -> [XDecl] -> Maybe ErrorDetails
findError :: Name -> [XDecl] -> Maybe ErrorDetails
findError Name
pname [XDecl]
xs =
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find forall {typ}. GenXDecl typ -> Bool
f [XDecl]
xs of
Maybe XDecl
Nothing -> forall a. Maybe a
Nothing
Just (XError Name
name Int
code Maybe Alignment
alignment [GenStructElem Type]
elems) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name
-> Int -> Maybe Alignment -> [GenStructElem Type] -> ErrorDetails
ErrorDetails Name
name Int
code Maybe Alignment
alignment [GenStructElem Type]
elems
Maybe XDecl
_ -> forall a. HasCallStack => Name -> a
error Name
"impossible: fatal error in Data.XCB.FromXML.findError"
where f :: GenXDecl typ -> Bool
f (XError Name
name Int
_ Maybe Alignment
_ [GenStructElem typ]
_) | Name
name forall a. Eq a => a -> a -> Bool
== Name
pname = Bool
True
f GenXDecl typ
_ = Bool
False
findEvent :: Name -> [XDecl] -> Maybe EventDetails
findEvent :: Name -> [XDecl] -> Maybe EventDetails
findEvent Name
pname [XDecl]
xs =
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find forall {typ}. GenXDecl typ -> Bool
f [XDecl]
xs of
Maybe XDecl
Nothing -> forall a. Maybe a
Nothing
Just (XEvent Name
name Int
code Maybe Alignment
alignment Maybe Bool
xge [GenStructElem Type]
elems Maybe Bool
noseq) ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name
-> Int
-> Maybe Alignment
-> Maybe Bool
-> [GenStructElem Type]
-> Maybe Bool
-> EventDetails
EventDetails Name
name Int
code Maybe Alignment
alignment Maybe Bool
xge [GenStructElem Type]
elems Maybe Bool
noseq
Maybe XDecl
_ -> forall a. HasCallStack => Name -> a
error Name
"impossible: fatal error in Data.XCB.FromXML.findEvent"
where f :: GenXDecl typ -> Bool
f (XEvent Name
name Int
_ Maybe Alignment
_ Maybe Bool
_ [GenStructElem typ]
_ Maybe Bool
_) | Name
name forall a. Eq a => a -> a -> Bool
== Name
pname = Bool
True
f GenXDecl typ
_ = Bool
False
data EventDetails = EventDetails Name Int (Maybe Alignment) (Maybe Bool) [StructElem] (Maybe Bool)
data ErrorDetails = ErrorDetails Name Int (Maybe Alignment) [StructElem]
fromString :: String -> ReaderT [XHeader] Maybe XHeader
fromString :: Name -> ReaderT [XHeader] Maybe XHeader
fromString Name
str = do
el :: Element
el@(Element QName
_qname [Attr]
_ats [Content]
cnt Maybe Line
_) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. XmlSource s => s -> Maybe Element
parseXMLDoc Name
str
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Bool
`named` Name
"xcb"
Name
header <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"header"
let name :: Maybe Name
name = Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"extension-name"
xname :: Maybe Name
xname = Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"extension-xname"
maj_ver :: Maybe Int
maj_ver = Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"major-version" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
min_ver :: Maybe Int
min_ver = Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"minor-version" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
multiword :: Maybe Bool
multiword = Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"extension-multiword" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
ensureUpper
[XDecl]
decls <- forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\[XHeader]
r -> ([XHeader]
r,Name
header)) forall a b. (a -> b) -> a -> b
$ [Content] -> Parse [XDecl]
extractDecls [Content]
cnt
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ XHeader {xheader_header :: Name
xheader_header = Name
header
,xheader_xname :: Maybe Name
xheader_xname = Maybe Name
xname
,xheader_name :: Maybe Name
xheader_name = Maybe Name
name
,xheader_multiword :: Maybe Bool
xheader_multiword = Maybe Bool
multiword
,xheader_major_version :: Maybe Int
xheader_major_version = Maybe Int
maj_ver
,xheader_minor_version :: Maybe Int
xheader_minor_version = Maybe Int
min_ver
,xheader_decls :: [XDecl]
xheader_decls = [XDecl]
decls
}
extractDecls :: [Content] -> Parse [XDecl]
= forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Element -> Parse XDecl
declFromElem forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Content] -> [Element]
onlyElems
declFromElem :: Element -> Parse XDecl
declFromElem :: Element -> Parse XDecl
declFromElem Element
el
| Element
el Element -> Name -> Bool
`named` Name
"request" = Element -> Parse XDecl
xrequest Element
el
| Element
el Element -> Name -> Bool
`named` Name
"event" = Element -> Parse XDecl
xevent Element
el
| Element
el Element -> Name -> Bool
`named` Name
"eventcopy" = Element -> Parse XDecl
xevcopy Element
el
| Element
el Element -> Name -> Bool
`named` Name
"error" = Element -> Parse XDecl
xerror Element
el
| Element
el Element -> Name -> Bool
`named` Name
"errorcopy" = Element -> Parse XDecl
xercopy Element
el
| Element
el Element -> Name -> Bool
`named` Name
"struct" = Element -> Parse XDecl
xstruct Element
el
| Element
el Element -> Name -> Bool
`named` Name
"union" = Element -> Parse XDecl
xunion Element
el
| Element
el Element -> Name -> Bool
`named` Name
"xidtype" = Element -> Parse XDecl
xidtype Element
el
| Element
el Element -> Name -> Bool
`named` Name
"xidunion" = Element -> Parse XDecl
xidunion Element
el
| Element
el Element -> Name -> Bool
`named` Name
"typedef" = Element -> Parse XDecl
xtypedef Element
el
| Element
el Element -> Name -> Bool
`named` Name
"enum" = Element -> Parse XDecl
xenum Element
el
| Element
el Element -> Name -> Bool
`named` Name
"import" = Element -> Parse XDecl
ximport Element
el
| Element
el Element -> Name -> Bool
`named` Name
"eventstruct" = Element -> Parse XDecl
xeventstruct Element
el
| Bool
otherwise = forall (m :: * -> *) a. MonadPlus m => m a
mzero
ximport :: Element -> Parse XDecl
ximport :: Element -> Parse XDecl
ximport = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall typ. Name -> GenXDecl typ
XImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
strContent
xenum :: Element -> Parse XDecl
xenum :: Element -> Parse XDecl
xenum Element
el = do
Name
nm <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
[EnumElem Type]
fields <- forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Element -> Parse (EnumElem Type)
enumField forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EnumElem Type]
fields
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> [EnumElem typ] -> GenXDecl typ
XEnum Name
nm [EnumElem Type]
fields
enumField :: Element -> Parse (EnumElem Type)
enumField :: Element -> Parse (EnumElem Type)
enumField Element
el = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Bool
`named` Name
"item"
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
let expr :: Maybe XExpression
expr = forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> Maybe (Expression typ) -> EnumElem typ
EnumElem Name
name Maybe XExpression
expr
xrequest :: Element -> Parse XDecl
xrequest :: Element -> Parse XDecl
xrequest Element
el = do
Name
nm <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
Int
code <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"opcode" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
(Maybe Alignment
alignment, [Element]
xs) <- forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
[GenStructElem Type]
fields <- forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField forall a b. (a -> b) -> a -> b
$ [Element]
xs
let reply :: Maybe XReply
reply = Element -> Maybe XReply
getReply Element
el
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Name
-> Int
-> Maybe Alignment
-> [GenStructElem typ]
-> Maybe (GenXReply typ)
-> GenXDecl typ
XRequest Name
nm Int
code Maybe Alignment
alignment [GenStructElem Type]
fields Maybe XReply
reply
getReply :: Element -> Maybe XReply
getReply :: Element -> Maybe XReply
getReply Element
el = do
Element
childElem <- Name -> QName
unqual Name
"reply" QName -> Element -> Maybe Element
`findChild` Element
el
(Maybe Alignment
alignment, [Element]
xs) <- forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
childElem
[GenStructElem Type]
fields <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField [Element]
xs
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStructElem Type]
fields
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Maybe Alignment -> [GenStructElem typ] -> GenXReply typ
GenXReply Maybe Alignment
alignment [GenStructElem Type]
fields
xevent :: Element -> Parse XDecl
xevent :: Element -> Parse XDecl
xevent Element
el = do
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
Int
number <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"number" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
let xge :: Maybe Bool
xge = Name -> Name
ensureUpper forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"xge") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
let noseq :: Maybe Bool
noseq = Name -> Name
ensureUpper forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"no-sequence-number") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
(Maybe Alignment
alignment, [Element]
xs) <- forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment (Element -> [Element]
elChildren Element
el)
[GenStructElem Type]
fields <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField forall a b. (a -> b) -> a -> b
$ [Element]
xs
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStructElem Type]
fields
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Name
-> Int
-> Maybe Alignment
-> Maybe Bool
-> [GenStructElem typ]
-> Maybe Bool
-> GenXDecl typ
XEvent Name
name Int
number Maybe Alignment
alignment Maybe Bool
xge [GenStructElem Type]
fields Maybe Bool
noseq
xevcopy :: Element -> Parse XDecl
xevcopy :: Element -> Parse XDecl
xevcopy Element
el = do
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
Int
number <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"number" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
Name
ref <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"ref"
let (Maybe Name
mname,Name
evname) = Name -> (Maybe Name, Name)
splitRef Name
ref
Maybe EventDetails
details <- Maybe Name -> Name -> Parse (Maybe EventDetails)
lookupEvent Maybe Name
mname Name
evname
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ let EventDetails Name
_ Int
_ Maybe Alignment
alignment Maybe Bool
xge [GenStructElem Type]
fields Maybe Bool
noseq =
case Maybe EventDetails
details of
Maybe EventDetails
Nothing ->
forall a. HasCallStack => Name -> a
error forall a b. (a -> b) -> a -> b
$ Name
"Unresolved event: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show Maybe Name
mname forall a. [a] -> [a] -> [a]
++ Name
" " forall a. [a] -> [a] -> [a]
++ Name
ref
Just EventDetails
x -> EventDetails
x
in forall typ.
Name
-> Int
-> Maybe Alignment
-> Maybe Bool
-> [GenStructElem typ]
-> Maybe Bool
-> GenXDecl typ
XEvent Name
name Int
number Maybe Alignment
alignment Maybe Bool
xge [GenStructElem Type]
fields Maybe Bool
noseq
mkType :: String -> Type
mkType :: Name -> Type
mkType Name
str =
let (Maybe Name
mname, Name
name) = Name -> (Maybe Name, Name)
splitRef Name
str
in case Maybe Name
mname of
Just Name
modifier -> Name -> Name -> Type
QualType Name
modifier Name
name
Maybe Name
Nothing -> Name -> Type
UnQualType Name
name
splitRef :: Name -> (Maybe Name, Name)
splitRef :: Name -> (Maybe Name, Name)
splitRef Name
ref = case Char -> Name -> (Name, Name)
split Char
':' Name
ref of
(Name
x,Name
"") -> (forall a. Maybe a
Nothing, Name
x)
(Name
a, Name
b) -> (forall a. a -> Maybe a
Just Name
a, Name
b)
split :: Char -> String -> (String, String)
split :: Char -> Name -> (Name, Name)
split Char
c = Name -> (Name, Name)
go
where go :: Name -> (Name, Name)
go [] = ([],[])
go (Char
x:Name
xs) | Char
x forall a. Eq a => a -> a -> Bool
== Char
c = ([],Name
xs)
| Bool
otherwise =
let (Name
lefts, Name
rights) = Name -> (Name, Name)
go Name
xs
in (Char
xforall a. a -> [a] -> [a]
:Name
lefts,Name
rights)
xerror :: Element -> Parse XDecl
xerror :: Element -> Parse XDecl
xerror Element
el = do
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
Int
number <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"number" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
(Maybe Alignment
alignment, [Element]
xs) <- forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
[GenStructElem Type]
fields <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField forall a b. (a -> b) -> a -> b
$ [Element]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Name
-> Int -> Maybe Alignment -> [GenStructElem typ] -> GenXDecl typ
XError Name
name Int
number Maybe Alignment
alignment [GenStructElem Type]
fields
xercopy :: Element -> Parse XDecl
xercopy :: Element -> Parse XDecl
xercopy Element
el = do
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
Int
number <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"number" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
Name
ref <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"ref"
let (Maybe Name
mname, Name
ername) = Name -> (Maybe Name, Name)
splitRef Name
ref
Maybe ErrorDetails
details <- Maybe Name -> Name -> Parse (Maybe ErrorDetails)
lookupError Maybe Name
mname Name
ername
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall typ.
Name
-> Int -> Maybe Alignment -> [GenStructElem typ] -> GenXDecl typ
XError Name
name Int
number) forall a b. (a -> b) -> a -> b
$ case Maybe ErrorDetails
details of
Maybe ErrorDetails
Nothing -> forall a. HasCallStack => Name -> a
error forall a b. (a -> b) -> a -> b
$ Name
"Unresolved error: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show Maybe Name
mname forall a. [a] -> [a] -> [a]
++ Name
" " forall a. [a] -> [a] -> [a]
++ Name
ref
Just (ErrorDetails Name
_ Int
_ Maybe Alignment
alignment [GenStructElem Type]
elems) -> (Maybe Alignment
alignment, [GenStructElem Type]
elems)
xstruct :: Element -> Parse XDecl
xstruct :: Element -> Parse XDecl
xstruct Element
el = do
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
(Maybe Alignment
alignment, [Element]
xs) <- forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
[GenStructElem Type]
fields <- forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField forall a b. (a -> b) -> a -> b
$ [Element]
xs
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStructElem Type]
fields
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Name -> Maybe Alignment -> [GenStructElem typ] -> GenXDecl typ
XStruct Name
name Maybe Alignment
alignment [GenStructElem Type]
fields
xunion :: Element -> Parse XDecl
xunion :: Element -> Parse XDecl
xunion Element
el = do
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
(Maybe Alignment
alignment, [Element]
xs) <- forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
[GenStructElem Type]
fields <- forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField forall a b. (a -> b) -> a -> b
$ [Element]
xs
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStructElem Type]
fields
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Name -> Maybe Alignment -> [GenStructElem typ] -> GenXDecl typ
XUnion Name
name Maybe Alignment
alignment [GenStructElem Type]
fields
xidtype :: Element -> Parse XDecl
xidtype :: Element -> Parse XDecl
xidtype Element
el = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall typ. Name -> GenXDecl typ
XidType forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
xidunion :: Element -> Parse XDecl
xidunion :: Element -> Parse XDecl
xidunion Element
el = do
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
let types :: [XidUnionElem]
types = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe XidUnionElem
xidUnionElem forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [XidUnionElem]
types
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> [GenXidUnionElem typ] -> GenXDecl typ
XidUnion Name
name [XidUnionElem]
types
xidUnionElem :: Element -> Maybe XidUnionElem
xidUnionElem :: Element -> Maybe XidUnionElem
xidUnionElem Element
el = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Bool
`named` Name
"type"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. typ -> GenXidUnionElem typ
XidUnionElem forall a b. (a -> b) -> a -> b
$ Name -> Type
mkType forall a b. (a -> b) -> a -> b
$ Element -> Name
strContent Element
el
xtypedef :: Element -> Parse XDecl
xtypedef :: Element -> Parse XDecl
xtypedef Element
el = do
Type
oldtyp <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"oldname"
Name
newname <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"newname"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> typ -> GenXDecl typ
XTypeDef Name
newname Type
oldtyp
xeventstruct :: Element -> Parse XDecl
xeventstruct :: Element -> Parse XDecl
xeventstruct Element
el = do
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
[AllowedEvent]
allowed <- forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt forall (m :: * -> *).
(MonadPlus m, Functor m) =>
Element -> m AllowedEvent
allowedEvent forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> [AllowedEvent] -> GenXDecl typ
XEventStruct Name
name [AllowedEvent]
allowed
allowedEvent :: (MonadPlus m, Functor m) => Element -> m AllowedEvent
allowedEvent :: forall (m :: * -> *).
(MonadPlus m, Functor m) =>
Element -> m AllowedEvent
allowedEvent Element
el = do
Name
extension <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
Bool
xge <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"xge" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
Int
opMin <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"opcode-min" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
Int
opMax <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"opcode-max" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Bool -> Int -> Int -> AllowedEvent
AllowedEvent Name
extension Bool
xge Int
opMin Int
opMax
structField :: (MonadFail m, MonadPlus m, Functor m) => Element -> m StructElem
structField :: forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField Element
el
| Element
el Element -> Name -> Bool
`named` Name
"field" = do
Type
typ <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"type"
let enum :: Maybe Type
enum = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"enum"
let mask :: Maybe Type
mask = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"mask"
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Name -> typ -> Maybe typ -> Maybe typ -> GenStructElem typ
SField Name
name Type
typ Maybe Type
enum Maybe Type
mask
| Element
el Element -> Name -> Bool
`named` Name
"pad" = do
let bytes :: Maybe (GenStructElem typ)
bytes = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall typ. PadType -> Int -> GenStructElem typ
Pad PadType
PadBytes) forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"bytes" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
let align :: Maybe (GenStructElem typ)
align = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall typ. PadType -> Int -> GenStructElem typ
Pad PadType
PadAlignment) forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"align" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [forall {typ}. Maybe (GenStructElem typ)
bytes, forall {typ}. Maybe (GenStructElem typ)
align]
| Element
el Element -> Name -> Bool
`named` Name
"list" = do
Type
typ <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"type"
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
let enum :: Maybe Type
enum = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"enum"
let expr :: Maybe XExpression
expr = forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Name
-> typ -> Maybe (Expression typ) -> Maybe typ -> GenStructElem typ
List Name
name Type
typ Maybe XExpression
expr Maybe Type
enum
| Element
el Element -> Name -> Bool
`named` Name
"valueparam" = do
Type
mask_typ <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"value-mask-type"
Name
mask_name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"value-mask-name"
let mask_pad :: Maybe Int
mask_pad = Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"value-mask-pad" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
Name
list_name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"value-list-name"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. typ -> Name -> Maybe Int -> Name -> GenStructElem typ
ValueParam Type
mask_typ Name
mask_name Maybe Int
mask_pad Name
list_name
| Element
el Element -> Name -> Bool
`named` Name
"switch" = do
Name
nm <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
(Element
exprEl,[Element]
caseEls) <- forall (m :: * -> *).
MonadPlus m =>
Element -> m (Element, [Element])
unconsChildren Element
el
XExpression
expr <- forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression Element
exprEl
(Maybe Alignment
alignment, [Element]
xs) <- forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment forall a b. (a -> b) -> a -> b
$ [Element]
caseEls
[BitCase]
cases <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m BitCase
bitCase [Element]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Name
-> Expression typ
-> Maybe Alignment
-> [GenBitCase typ]
-> GenStructElem typ
Switch Name
nm XExpression
expr Maybe Alignment
alignment [BitCase]
cases
| Element
el Element -> Name -> Bool
`named` Name
"exprfield" = do
Type
typ <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType forall a b. (a -> b) -> a -> b
$ Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"type"
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
XExpression
expr <- forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> typ -> Expression typ -> GenStructElem typ
ExprField Name
name Type
typ XExpression
expr
| Element
el Element -> Name -> Bool
`named` Name
"reply" = forall (m :: * -> *) a. MonadFail m => Name -> m a
fail Name
""
| Element
el Element -> Name -> Bool
`named` Name
"doc" = do
[Element]
fields <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m [Element]
`children` Name
"field"
let mkField :: Element -> Maybe (Name, Name)
mkField = \Element
x -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
y -> (Name
y, Element -> Name
strContent Element
x)) forall a b. (a -> b) -> a -> b
$ Element
x forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
fields' :: Map Name Name
fields' = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Element -> Maybe (Name, Name)
mkField [Element]
fields
sees :: [Element]
sees = QName -> Element -> [Element]
findChildren (Name -> QName
unqual Name
"see") Element
el
sees' :: [(Name, Name)]
sees' = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Element]
sees forall a b. (a -> b) -> a -> b
$ \Element
s -> do Name
typ <- Element
s forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"type"
Name
name <- Element
s forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
typ, Name
name)
brief :: Maybe Name
brief = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> Name
strContent forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe Element
findChild (Name -> QName
unqual Name
"brief") Element
el
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Maybe Name -> Map Name Name -> [(Name, Name)] -> GenStructElem typ
Doc Maybe Name
brief Map Name Name
fields' [(Name, Name)]
sees'
| Element
el Element -> Name -> Bool
`named` Name
"fd" = do
Name
name <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> GenStructElem typ
Fd Name
name
| Element
el Element -> Name -> Bool
`named` Name
"length" = do
XExpression
expr <- forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
let typ :: Type
typ = Name -> Type
mkType Name
"CARD32"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. typ -> Expression typ -> GenStructElem typ
Length Type
typ XExpression
expr
| Bool
otherwise = let name :: QName
name = Element -> QName
elName Element
el
in forall a. HasCallStack => Name -> a
error forall a b. (a -> b) -> a -> b
$ Name
"I don't know what to do with structelem "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show QName
name
bitCase :: (MonadFail m, MonadPlus m, Functor m) => Element -> m BitCase
bitCase :: forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m BitCase
bitCase Element
el | Element
el Element -> Name -> Bool
`named` Name
"bitcase" Bool -> Bool -> Bool
|| Element
el Element -> Name -> Bool
`named` Name
"case" = do
let mName :: Maybe Name
mName = Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
(Element
exprEl, [Element]
fieldEls) <- forall (m :: * -> *).
MonadPlus m =>
Element -> m (Element, [Element])
unconsChildren Element
el
XExpression
expr <- forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression Element
exprEl
(Maybe Alignment
alignment, [Element]
xs) <- forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment forall a b. (a -> b) -> a -> b
$ [Element]
fieldEls
[GenStructElem Type]
fields <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField [Element]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Maybe Name
-> Expression typ
-> Maybe Alignment
-> [GenStructElem typ]
-> GenBitCase typ
BitCase Maybe Name
mName XExpression
expr Maybe Alignment
alignment [GenStructElem Type]
fields
| Bool
otherwise =
let name :: QName
name = Element -> QName
elName Element
el
in forall a. HasCallStack => Name -> a
error forall a b. (a -> b) -> a -> b
$ Name
"Invalid bitCase: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show QName
name
expression :: (MonadFail m, MonadPlus m, Functor m) => Element -> m XExpression
expression :: forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression Element
el | Element
el Element -> Name -> Bool
`named` Name
"fieldref"
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> Expression typ
FieldRef forall a b. (a -> b) -> a -> b
$ Element -> Name
strContent Element
el
| Element
el Element -> Name -> Bool
`named` Name
"enumref" = do
Type
enumTy <- Name -> Type
mkType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"ref"
let enumVal :: Name
enumVal = Element -> Name
strContent Element
el
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Name
enumVal forall a. Eq a => a -> a -> Bool
/= Name
""
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. typ -> Name -> Expression typ
EnumRef Type
enumTy Name
enumVal
| Element
el Element -> Name -> Bool
`named` Name
"value"
= forall typ. Int -> Expression typ
Value forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM (Element -> Name
strContent Element
el)
| Element
el Element -> Name -> Bool
`named` Name
"bit"
= forall typ. Int -> Expression typ
Bit forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` do
Int
n <- forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM (Element -> Name
strContent Element
el)
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
n forall a. Ord a => a -> a -> Bool
>= Int
0
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
| Element
el Element -> Name -> Bool
`named` Name
"op" = do
Binop
binop <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"op" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadPlus m => Name -> m Binop
toBinop
[XExpression
exprLhs,XExpression
exprRhs] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ.
Binop -> Expression typ -> Expression typ -> Expression typ
Op Binop
binop XExpression
exprLhs XExpression
exprRhs
| Element
el Element -> Name -> Bool
`named` Name
"unop" = do
Unop
op <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"op" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadPlus m => Name -> m Unop
toUnop
XExpression
expr <- forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Unop -> Expression typ -> Expression typ
Unop Unop
op XExpression
expr
| Element
el Element -> Name -> Bool
`named` Name
"popcount" = do
XExpression
expr <- forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Expression typ -> Expression typ
PopCount XExpression
expr
| Element
el Element -> Name -> Bool
`named` Name
"sumof" = do
Name
ref <- Element
el forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"ref"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> Expression typ
SumOf Name
ref
| Element
el Element -> Name -> Bool
`named` Name
"paramref"
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall typ. Name -> Expression typ
ParamRef forall a b. (a -> b) -> a -> b
$ Element -> Name
strContent Element
el
| Bool
otherwise =
let nm :: QName
nm = Element -> QName
elName Element
el
in forall a. HasCallStack => Name -> a
error forall a b. (a -> b) -> a -> b
$ Name
"Unknown epression " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show QName
nm forall a. [a] -> [a] -> [a]
++ Name
" in Data.XCB.FromXML.expression"
toBinop :: MonadPlus m => String -> m Binop
toBinop :: forall (m :: * -> *). MonadPlus m => Name -> m Binop
toBinop Name
"+" = forall (m :: * -> *) a. Monad m => a -> m a
return Binop
Add
toBinop Name
"-" = forall (m :: * -> *) a. Monad m => a -> m a
return Binop
Sub
toBinop Name
"*" = forall (m :: * -> *) a. Monad m => a -> m a
return Binop
Mult
toBinop Name
"/" = forall (m :: * -> *) a. Monad m => a -> m a
return Binop
Div
toBinop Name
"&" = forall (m :: * -> *) a. Monad m => a -> m a
return Binop
And
toBinop Name
"&" = forall (m :: * -> *) a. Monad m => a -> m a
return Binop
And
toBinop Name
">>" = forall (m :: * -> *) a. Monad m => a -> m a
return Binop
RShift
toBinop Name
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero
toUnop :: MonadPlus m => String -> m Unop
toUnop :: forall (m :: * -> *). MonadPlus m => Name -> m Unop
toUnop Name
"~" = forall (m :: * -> *) a. Monad m => a -> m a
return Unop
Complement
toUnop Name
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero
firstChild :: MonadPlus m => Element -> m Element
firstChild :: forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild = forall (m :: * -> *) a. MonadPlus m => [a] -> m a
listToM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Element]
elChildren
unconsChildren :: MonadPlus m => Element -> m (Element, [Element])
unconsChildren :: forall (m :: * -> *).
MonadPlus m =>
Element -> m (Element, [Element])
unconsChildren Element
el
= case Element -> [Element]
elChildren Element
el of
(Element
x:[Element]
xs) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Element
x,[Element]
xs)
[Element]
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
listToM :: MonadPlus m => [a] -> m a
listToM :: forall (m :: * -> *) a. MonadPlus m => [a] -> m a
listToM [] = forall (m :: * -> *) a. MonadPlus m => m a
mzero
listToM (a
x:[a]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return a
x
named :: Element -> String -> Bool
named :: Element -> Name -> Bool
named (Element QName
qname [Attr]
_ [Content]
_ Maybe Line
_) Name
name | QName
qname forall a. Eq a => a -> a -> Bool
== Name -> QName
unqual Name
name = Bool
True
named Element
_ Name
_ = Bool
False
attr :: MonadPlus m => Element -> String -> m String
(Element QName
_ [Attr]
xs [Content]
_ Maybe Line
_) attr :: forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
name = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Attr -> Bool
p [Attr]
xs of
Just (Attr QName
_ Name
res) -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
res
Maybe Attr
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
where p :: Attr -> Bool
p (Attr QName
qname Name
_) | QName
qname forall a. Eq a => a -> a -> Bool
== Name -> QName
unqual Name
name = Bool
True
p Attr
_ = Bool
False
children :: MonadPlus m => Element -> String -> m [Element]
(Element QName
_ [Attr]
_ [Content]
xs Maybe Line
_) children :: forall (m :: * -> *). MonadPlus m => Element -> Name -> m [Element]
`children` Name
name = case forall a. (a -> Bool) -> [a] -> [a]
List.filter Content -> Bool
p [Content]
xs of
[] -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
[Content]
some -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Content] -> [Element]
onlyElems [Content]
some
where p :: Content -> Bool
p (Elem (Element QName
n [Attr]
_ [Content]
_ Maybe Line
_)) | QName
n forall a. Eq a => a -> a -> Bool
== Name -> QName
unqual Name
name = Bool
True
p Content
_ = Bool
False
readM :: (MonadPlus m, Read a) => String -> m a
readM :: forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadPlus m => [a] -> m a
listToM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ReadS a
reads