-- |
-- Module    :  Data.XCB.FromXML
-- Copyright :  (c) Antoine Latter 2008
-- License   :  BSD3
--
-- Maintainer:  Antoine Latter <aslatter@gmail.com>
-- 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.
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)

-- |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 :: [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

-- | Like 'readFile', but forces the encoding
-- of the file to UTF8.
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

-- |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 :: [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

-- 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 :: 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

-- 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 :: forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment (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)

-- 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 :: 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") -- implicit xproto import
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

-- lookup an event declaration by name.
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

-- lookup an error declaration by name.
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
findXHeader :: Name -> [XHeader] -> Maybe XHeader
findXHeader 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]

---

-- extract a single XHeader from a single XML document
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
                   }

-- attempts to extract declarations from XML content, discarding failures.
extractDecls :: [Content] -> Parse [XDecl]
extractDecls :: [Content] -> Parse [XDecl]
extractDecls = 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

-- attempt to extract a module declaration from an XML element
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
  -- TODO - I don't think I like 'mapAlt' here.
  -- I don't want to be silently dropping fields
  (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"
  -- do we have a qualified 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

-- we need to do string processing to distinguish qualified from
-- unqualified types.
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)

-- |Neither returned string contains the first occurance of the
-- supplied Char.
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
"" -- handled separate

    | 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
"&amp;" = 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


----
----
-- Utility functions
----
----

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

-- adapted from Network.CGI.Protocol
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