-- |
-- 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.
{-# LANGUAGE CPP #-}
module Data.XCB.FromXML(fromFiles
                       ,fromStrings
                       ) where

import Data.XCB.Types
import Data.XCB.Utils

import Text.XML.Light

import Data.List as List
import qualified Data.Map as Map
import Data.Maybe (catMaybes, mapMaybe, maybeToList)

import Control.Monad (MonadPlus (mzero, mplus), guard, liftM, liftM2)
import Control.Monad.Reader (ReaderT, runReaderT, ask, lift, withReaderT)
#if __GLASGOW_HASKELL__ < 900
import Control.Monad.Fail (MonadFail)
#endif
import System.IO (openFile, IOMode (ReadMode), hSetEncoding, utf8, hGetContents)

-- |Process the listed XML files.
-- Any files which fail to parse are silently dropped.
-- Any declaration in an XML file which fail to parse are
-- silently dropped.
fromFiles :: [FilePath] -> IO [XHeader]
fromFiles :: [Name] -> IO [XHeader]
fromFiles [Name]
xs = do
  [Name]
strings <- [IO Name] -> IO [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([IO Name] -> IO [Name]) -> [IO Name] -> IO [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> IO Name) -> [Name] -> [IO Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> IO Name
readFileUTF8 [Name]
xs
  [XHeader] -> IO [XHeader]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([XHeader] -> IO [XHeader]) -> [XHeader] -> IO [XHeader]
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 = (Name -> ReaderT [XHeader] Maybe XHeader)
-> [Name] -> ReaderT [XHeader] Maybe [XHeader]
forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Name -> ReaderT [XHeader] Maybe XHeader
fromString [Name]
xs
       headers :: [XHeader]
headers = [[XHeader]] -> [XHeader]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[XHeader]] -> [XHeader]) -> [[XHeader]] -> [XHeader]
forall a b. (a -> b) -> a -> b
$ Maybe [XHeader] -> [[XHeader]]
forall a. Maybe a -> [a]
maybeToList (Maybe [XHeader] -> [[XHeader]]) -> Maybe [XHeader] -> [[XHeader]]
forall a b. (a -> b) -> a -> b
$ ReaderT [XHeader] Maybe [XHeader] -> [XHeader] -> Maybe [XHeader]
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 = ([XHeader], Name) -> Name
forall a b. (a, b) -> b
snd (([XHeader], Name) -> Name)
-> ReaderT ([XHeader], Name) Maybe ([XHeader], Name) -> Parse Name
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ReaderT ([XHeader], Name) Maybe ([XHeader], Name)
forall r (m :: * -> *). MonadReader r m => m r
ask

allModules :: Parse [XHeader]
allModules :: Parse [XHeader]
allModules = ([XHeader], Name) -> [XHeader]
forall a b. (a, b) -> a
fst (([XHeader], Name) -> [XHeader])
-> ReaderT ([XHeader], Name) Maybe ([XHeader], Name)
-> Parse [XHeader]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ReaderT ([XHeader], Name) Maybe ([XHeader], Name)
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 Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"align" m Name -> (Name -> m Int) -> m Int
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
                               Int
offset <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"offset" m Name -> (Name -> m Int) -> m Int
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
                               (Maybe Alignment, [Element]) -> m (Maybe Alignment, [Element])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Alignment -> Maybe Alignment
forall a. a -> Maybe a
Just (Int -> Int -> Alignment
Alignment Int
align Int
offset), [Element]
xs)
                           | Bool
otherwise = (Maybe Alignment, [Element]) -> m (Maybe Alignment, [Element])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Alignment
forall a. Maybe a
Nothing, Element
el Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
xs)
extractAlignment [Element]
xs = (Maybe Alignment, [Element]) -> m (Maybe Alignment, [Element])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Alignment
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
  (Maybe a -> Maybe a -> Maybe a)
-> Parse (Maybe a) -> Parse (Maybe a) -> Parse (Maybe a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
forall a. ([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
lookupThingy [XDecl] -> Maybe a
f (Maybe Name -> Parse (Maybe a)) -> Maybe Name -> Parse (Maybe a)
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Name
forall a. a -> Maybe a
Just Name
lname)
               (([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
forall a. ([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
lookupThingy [XDecl] -> Maybe a
f (Maybe Name -> Parse (Maybe a)) -> Maybe Name -> Parse (Maybe a)
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Name
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
  Maybe a -> Parse (Maybe a)
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Parse (Maybe a)) -> Maybe a -> Parse (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
    XHeader
x <- Name -> [XHeader] -> Maybe XHeader
findXHeader Name
mname [XHeader]
xs
    [XDecl] -> Maybe a
f ([XDecl] -> Maybe a) -> [XDecl] -> Maybe a
forall a b. (a -> b) -> a -> b
$ XHeader -> [XDecl]
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 = (([XDecl] -> Maybe EventDetails)
 -> Maybe Name -> Parse (Maybe EventDetails))
-> Maybe Name
-> ([XDecl] -> Maybe EventDetails)
-> Parse (Maybe EventDetails)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([XDecl] -> Maybe EventDetails)
-> Maybe Name -> Parse (Maybe EventDetails)
forall a. ([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
lookupThingy Maybe Name
mname (([XDecl] -> Maybe EventDetails) -> Parse (Maybe EventDetails))
-> ([XDecl] -> Maybe EventDetails) -> Parse (Maybe EventDetails)
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 = (([XDecl] -> Maybe ErrorDetails)
 -> Maybe Name -> Parse (Maybe ErrorDetails))
-> Maybe Name
-> ([XDecl] -> Maybe ErrorDetails)
-> Parse (Maybe ErrorDetails)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([XDecl] -> Maybe ErrorDetails)
-> Maybe Name -> Parse (Maybe ErrorDetails)
forall a. ([XDecl] -> Maybe a) -> Maybe Name -> Parse (Maybe a)
lookupThingy Maybe Name
mname (([XDecl] -> Maybe ErrorDetails) -> Parse (Maybe ErrorDetails))
-> ([XDecl] -> Maybe ErrorDetails) -> Parse (Maybe ErrorDetails)
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 = (XHeader -> Bool) -> [XHeader] -> Maybe XHeader
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((XHeader -> Bool) -> [XHeader] -> Maybe XHeader)
-> (XHeader -> Bool) -> [XHeader] -> Maybe XHeader
forall a b. (a -> b) -> a -> b
$ \ XHeader
x -> XHeader -> Name
forall typ. GenXHeader typ -> Name
xheader_header XHeader
x Name -> Name -> Bool
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 (XDecl -> Bool) -> [XDecl] -> Maybe XDecl
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find XDecl -> Bool
forall {typ}. GenXDecl typ -> Bool
f [XDecl]
xs of
        Maybe XDecl
Nothing -> Maybe ErrorDetails
forall a. Maybe a
Nothing
        Just (XError Name
name Int
code Maybe Alignment
alignment [GenStructElem Type]
elems) -> ErrorDetails -> Maybe ErrorDetails
forall a. a -> Maybe a
Just (ErrorDetails -> Maybe ErrorDetails)
-> ErrorDetails -> Maybe ErrorDetails
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
_ -> Name -> Maybe ErrorDetails
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 Name -> Name -> Bool
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 (XDecl -> Bool) -> [XDecl] -> Maybe XDecl
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find XDecl -> Bool
forall {typ}. GenXDecl typ -> Bool
f [XDecl]
xs of
        Maybe XDecl
Nothing -> Maybe EventDetails
forall a. Maybe a
Nothing
        Just (XEvent Name
name Int
code Maybe Alignment
alignment Maybe Bool
xge [GenStructElem Type]
elems Maybe Bool
noseq) ->
            EventDetails -> Maybe EventDetails
forall a. a -> Maybe a
Just (EventDetails -> Maybe EventDetails)
-> EventDetails -> Maybe EventDetails
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
_ -> Name -> Maybe EventDetails
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 Name -> Name -> Bool
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
_) <- Maybe Element -> ReaderT [XHeader] Maybe Element
forall (m :: * -> *) a. Monad m => m a -> ReaderT [XHeader] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe Element -> ReaderT [XHeader] Maybe Element)
-> Maybe Element -> ReaderT [XHeader] Maybe Element
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc Name
str
  Bool -> ReaderT [XHeader] Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReaderT [XHeader] Maybe ())
-> Bool -> ReaderT [XHeader] Maybe ()
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Bool
`named` Name
"xcb"
  Name
header <- Element
el Element -> Name -> ReaderT [XHeader] Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"header"
  let name :: Maybe Name
name = Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"extension-name"
      xname :: Maybe Name
xname = Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"extension-xname"
      maj_ver :: Maybe Int
maj_ver = Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"major-version" Maybe Name -> (Name -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
      min_ver :: Maybe Int
min_ver = Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"minor-version" Maybe Name -> (Name -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
      multiword :: Maybe Bool
multiword = Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"extension-multiword" Maybe Name -> (Name -> Maybe Bool) -> Maybe Bool
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Maybe Bool
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM (Name -> Maybe Bool) -> (Name -> Name) -> Name -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
ensureUpper
  [XDecl]
decls <- ([XHeader] -> ([XHeader], Name))
-> ReaderT ([XHeader], Name) Maybe [XDecl]
-> ReaderT [XHeader] Maybe [XDecl]
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\[XHeader]
r -> ([XHeader]
r,Name
header)) (ReaderT ([XHeader], Name) Maybe [XDecl]
 -> ReaderT [XHeader] Maybe [XDecl])
-> ReaderT ([XHeader], Name) Maybe [XDecl]
-> ReaderT [XHeader] Maybe [XDecl]
forall a b. (a -> b) -> a -> b
$ [Content] -> ReaderT ([XHeader], Name) Maybe [XDecl]
extractDecls [Content]
cnt
  XHeader -> ReaderT [XHeader] Maybe XHeader
forall a. a -> ReaderT [XHeader] Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XHeader -> ReaderT [XHeader] Maybe XHeader)
-> XHeader -> ReaderT [XHeader] Maybe XHeader
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] -> ReaderT ([XHeader], Name) Maybe [XDecl]
extractDecls = (Element -> ReaderT ([XHeader], Name) Maybe XDecl)
-> [Element] -> ReaderT ([XHeader], Name) Maybe [XDecl]
forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Element -> ReaderT ([XHeader], Name) Maybe XDecl
declFromElem ([Element] -> ReaderT ([XHeader], Name) Maybe [XDecl])
-> ([Content] -> [Element])
-> [Content]
-> ReaderT ([XHeader], Name) Maybe [XDecl]
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 -> ReaderT ([XHeader], Name) Maybe XDecl
declFromElem Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"request" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xrequest Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"event"   = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xevent Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"eventcopy" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xevcopy Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"error" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xerror Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"errorcopy" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xercopy Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"struct" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xstruct Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"union" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xunion Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"xidtype" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xidtype Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"xidunion" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xidunion Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"typedef" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xtypedef Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"enum" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xenum Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"import" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
ximport Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"eventstruct" = Element -> ReaderT ([XHeader], Name) Maybe XDecl
xeventstruct Element
el
    | Bool
otherwise = ReaderT ([XHeader], Name) Maybe XDecl
forall a. ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero


ximport :: Element -> Parse XDecl
ximport :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
ximport = XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> (Element -> XDecl)
-> Element
-> ReaderT ([XHeader], Name) Maybe XDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> XDecl
forall typ. Name -> GenXDecl typ
XImport (Name -> XDecl) -> (Element -> Name) -> Element -> XDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
strContent

xenum :: Element -> Parse XDecl
xenum :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xenum Element
el = do
  Name
nm <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  [EnumElem Type]
fields <- (Element -> ReaderT ([XHeader], Name) Maybe (EnumElem Type))
-> [Element] -> ReaderT ([XHeader], Name) Maybe [EnumElem Type]
forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Element -> ReaderT ([XHeader], Name) Maybe (EnumElem Type)
enumField ([Element] -> ReaderT ([XHeader], Name) Maybe [EnumElem Type])
-> [Element] -> ReaderT ([XHeader], Name) Maybe [EnumElem Type]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
  Bool -> ReaderT ([XHeader], Name) Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReaderT ([XHeader], Name) Maybe ())
-> Bool -> ReaderT ([XHeader], Name) Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [EnumElem Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EnumElem Type]
fields
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Name -> [EnumElem Type] -> XDecl
forall typ. Name -> [EnumElem typ] -> GenXDecl typ
XEnum Name
nm [EnumElem Type]
fields

enumField :: Element -> Parse (EnumElem Type)
enumField :: Element -> ReaderT ([XHeader], Name) Maybe (EnumElem Type)
enumField Element
el = do
  Bool -> ReaderT ([XHeader], Name) Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReaderT ([XHeader], Name) Maybe ())
-> Bool -> ReaderT ([XHeader], Name) Maybe ()
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Bool
`named` Name
"item"
  Name
name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  let expr :: Maybe XExpression
expr = Element -> Maybe Element
forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el Maybe Element
-> (Element -> Maybe XExpression) -> Maybe XExpression
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> Maybe XExpression
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
  EnumElem Type -> ReaderT ([XHeader], Name) Maybe (EnumElem Type)
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumElem Type -> ReaderT ([XHeader], Name) Maybe (EnumElem Type))
-> EnumElem Type -> ReaderT ([XHeader], Name) Maybe (EnumElem Type)
forall a b. (a -> b) -> a -> b
$ Name -> Maybe XExpression -> EnumElem Type
forall typ. Name -> Maybe (Expression typ) -> EnumElem typ
EnumElem Name
name Maybe XExpression
expr

xrequest :: Element -> Parse XDecl
xrequest :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xrequest Element
el = do
  Name
nm <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  Int
code <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"opcode" Parse Name
-> (Name -> ReaderT ([XHeader], Name) Maybe Int)
-> ReaderT ([XHeader], Name) Maybe Int
forall a b.
ReaderT ([XHeader], Name) Maybe a
-> (a -> ReaderT ([XHeader], Name) Maybe b)
-> ReaderT ([XHeader], Name) Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> ReaderT ([XHeader], Name) Maybe Int
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) <- [Element]
-> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element])
forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment ([Element]
 -> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element]))
-> [Element]
-> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element])
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
  [GenStructElem Type]
fields <- (Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type))
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type)
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField ([Element] -> ReaderT ([XHeader], Name) Maybe [GenStructElem Type])
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall a b. (a -> b) -> a -> b
$ [Element]
xs
  let reply :: Maybe XReply
reply = Element -> Maybe XReply
getReply Element
el
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Name
-> Int
-> Maybe Alignment
-> [GenStructElem Type]
-> Maybe XReply
-> XDecl
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) <- [Element] -> Maybe (Maybe Alignment, [Element])
forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment ([Element] -> Maybe (Maybe Alignment, [Element]))
-> [Element] -> Maybe (Maybe Alignment, [Element])
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
childElem
  [GenStructElem Type]
fields <- (Element -> Maybe (GenStructElem Type))
-> [Element] -> Maybe [GenStructElem Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> Maybe (GenStructElem Type)
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField [Element]
xs
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [GenStructElem Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStructElem Type]
fields
  XReply -> Maybe XReply
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XReply -> Maybe XReply) -> XReply -> Maybe XReply
forall a b. (a -> b) -> a -> b
$ Maybe Alignment -> [GenStructElem Type] -> XReply
forall typ. Maybe Alignment -> [GenStructElem typ] -> GenXReply typ
GenXReply Maybe Alignment
alignment [GenStructElem Type]
fields

xevent :: Element -> Parse XDecl
xevent :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xevent Element
el = do
  Name
name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  Int
number <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"number" Parse Name
-> (Name -> ReaderT ([XHeader], Name) Maybe Int)
-> ReaderT ([XHeader], Name) Maybe Int
forall a b.
ReaderT ([XHeader], Name) Maybe a
-> (a -> ReaderT ([XHeader], Name) Maybe b)
-> ReaderT ([XHeader], Name) Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> ReaderT ([XHeader], Name) Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
  let xge :: Maybe Bool
xge = Name -> Name
ensureUpper (Name -> Name) -> Maybe Name -> Maybe Name
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"xge") Maybe Name -> (Name -> Maybe Bool) -> Maybe Bool
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Maybe Bool
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
  let noseq :: Maybe Bool
noseq = Name -> Name
ensureUpper (Name -> Name) -> Maybe Name -> Maybe Name
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"no-sequence-number") Maybe Name -> (Name -> Maybe Bool) -> Maybe Bool
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Maybe Bool
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
  (Maybe Alignment
alignment, [Element]
xs) <- [Element]
-> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element])
forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment (Element -> [Element]
elChildren Element
el)
  [GenStructElem Type]
fields <- (Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type))
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type)
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField ([Element] -> ReaderT ([XHeader], Name) Maybe [GenStructElem Type])
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall a b. (a -> b) -> a -> b
$ [Element]
xs
  Bool -> ReaderT ([XHeader], Name) Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReaderT ([XHeader], Name) Maybe ())
-> Bool -> ReaderT ([XHeader], Name) Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [GenStructElem Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStructElem Type]
fields
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Name
-> Int
-> Maybe Alignment
-> Maybe Bool
-> [GenStructElem Type]
-> Maybe Bool
-> XDecl
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 -> ReaderT ([XHeader], Name) Maybe XDecl
xevcopy Element
el = do
  Name
name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  Int
number <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"number" Parse Name
-> (Name -> ReaderT ([XHeader], Name) Maybe Int)
-> ReaderT ([XHeader], Name) Maybe Int
forall a b.
ReaderT ([XHeader], Name) Maybe a
-> (a -> ReaderT ([XHeader], Name) Maybe b)
-> ReaderT ([XHeader], Name) Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> ReaderT ([XHeader], Name) Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
  Name
ref <- Element
el Element -> Name -> Parse Name
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
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
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 ->
                       Name -> EventDetails
forall a. HasCallStack => Name -> a
error (Name -> EventDetails) -> Name -> EventDetails
forall a b. (a -> b) -> a -> b
$ Name
"Unresolved event: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Maybe Name -> Name
forall a. Show a => a -> Name
show Maybe Name
mname Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
ref
                   Just EventDetails
x -> EventDetails
x  
           in Name
-> Int
-> Maybe Alignment
-> Maybe Bool
-> [GenStructElem Type]
-> Maybe Bool
-> XDecl
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
"") -> (Maybe Name
forall a. Maybe a
Nothing, Name
x)
                 (Name
a, Name
b) -> (Name -> Maybe Name
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 Char -> Char -> Bool
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
xChar -> Name -> Name
forall a. a -> [a] -> [a]
:Name
lefts,Name
rights)


xerror :: Element -> Parse XDecl
xerror :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xerror Element
el = do
  Name
name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  Int
number <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"number" Parse Name
-> (Name -> ReaderT ([XHeader], Name) Maybe Int)
-> ReaderT ([XHeader], Name) Maybe Int
forall a b.
ReaderT ([XHeader], Name) Maybe a
-> (a -> ReaderT ([XHeader], Name) Maybe b)
-> ReaderT ([XHeader], Name) Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> ReaderT ([XHeader], Name) Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
  (Maybe Alignment
alignment, [Element]
xs) <- [Element]
-> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element])
forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment ([Element]
 -> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element]))
-> [Element]
-> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element])
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
  [GenStructElem Type]
fields <- (Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type))
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type)
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField ([Element] -> ReaderT ([XHeader], Name) Maybe [GenStructElem Type])
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall a b. (a -> b) -> a -> b
$ [Element]
xs
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Name -> Int -> Maybe Alignment -> [GenStructElem Type] -> XDecl
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 -> ReaderT ([XHeader], Name) Maybe XDecl
xercopy Element
el = do
  Name
name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  Int
number <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"number" Parse Name
-> (Name -> ReaderT ([XHeader], Name) Maybe Int)
-> ReaderT ([XHeader], Name) Maybe Int
forall a b.
ReaderT ([XHeader], Name) Maybe a
-> (a -> ReaderT ([XHeader], Name) Maybe b)
-> ReaderT ([XHeader], Name) Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> ReaderT ([XHeader], Name) Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
  Name
ref <- Element
el Element -> Name -> Parse Name
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
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ (Maybe Alignment -> [GenStructElem Type] -> XDecl)
-> (Maybe Alignment, [GenStructElem Type]) -> XDecl
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Name -> Int -> Maybe Alignment -> [GenStructElem Type] -> XDecl
forall typ.
Name
-> Int -> Maybe Alignment -> [GenStructElem typ] -> GenXDecl typ
XError Name
name Int
number) ((Maybe Alignment, [GenStructElem Type]) -> XDecl)
-> (Maybe Alignment, [GenStructElem Type]) -> XDecl
forall a b. (a -> b) -> a -> b
$ case Maybe ErrorDetails
details of
               Maybe ErrorDetails
Nothing -> Name -> (Maybe Alignment, [GenStructElem Type])
forall a. HasCallStack => Name -> a
error (Name -> (Maybe Alignment, [GenStructElem Type]))
-> Name -> (Maybe Alignment, [GenStructElem Type])
forall a b. (a -> b) -> a -> b
$ Name
"Unresolved error: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Maybe Name -> Name
forall a. Show a => a -> Name
show Maybe Name
mname Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" " Name -> Name -> 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 -> ReaderT ([XHeader], Name) Maybe XDecl
xstruct Element
el = do
  Name
name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  (Maybe Alignment
alignment, [Element]
xs) <- [Element]
-> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element])
forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment ([Element]
 -> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element]))
-> [Element]
-> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element])
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
  [GenStructElem Type]
fields <- (Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type))
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type)
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField ([Element] -> ReaderT ([XHeader], Name) Maybe [GenStructElem Type])
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall a b. (a -> b) -> a -> b
$ [Element]
xs
  Bool -> ReaderT ([XHeader], Name) Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReaderT ([XHeader], Name) Maybe ())
-> Bool -> ReaderT ([XHeader], Name) Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [GenStructElem Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStructElem Type]
fields
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Alignment -> [GenStructElem Type] -> XDecl
forall typ.
Name -> Maybe Alignment -> [GenStructElem typ] -> GenXDecl typ
XStruct Name
name Maybe Alignment
alignment [GenStructElem Type]
fields

xunion :: Element -> Parse XDecl
xunion :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xunion Element
el = do
  Name
name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  (Maybe Alignment
alignment, [Element]
xs) <- [Element]
-> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element])
forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment ([Element]
 -> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element]))
-> [Element]
-> ReaderT ([XHeader], Name) Maybe (Maybe Alignment, [Element])
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
  [GenStructElem Type]
fields <- (Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type))
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Element -> ReaderT ([XHeader], Name) Maybe (GenStructElem Type)
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField ([Element] -> ReaderT ([XHeader], Name) Maybe [GenStructElem Type])
-> [Element]
-> ReaderT ([XHeader], Name) Maybe [GenStructElem Type]
forall a b. (a -> b) -> a -> b
$ [Element]
xs
  Bool -> ReaderT ([XHeader], Name) Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReaderT ([XHeader], Name) Maybe ())
-> Bool -> ReaderT ([XHeader], Name) Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [GenStructElem Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStructElem Type]
fields
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Alignment -> [GenStructElem Type] -> XDecl
forall typ.
Name -> Maybe Alignment -> [GenStructElem typ] -> GenXDecl typ
XUnion Name
name Maybe Alignment
alignment [GenStructElem Type]
fields

xidtype :: Element -> Parse XDecl
xidtype :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xidtype Element
el = (Name -> XDecl)
-> Parse Name -> ReaderT ([XHeader], Name) Maybe XDecl
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> XDecl
forall typ. Name -> GenXDecl typ
XidType (Parse Name -> ReaderT ([XHeader], Name) Maybe XDecl)
-> Parse Name -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"

xidunion :: Element -> Parse XDecl
xidunion :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xidunion Element
el = do
  Name
name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  let types :: [XidUnionElem]
types = (Element -> Maybe XidUnionElem) -> [Element] -> [XidUnionElem]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe XidUnionElem
xidUnionElem ([Element] -> [XidUnionElem]) -> [Element] -> [XidUnionElem]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
  Bool -> ReaderT ([XHeader], Name) Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReaderT ([XHeader], Name) Maybe ())
-> Bool -> ReaderT ([XHeader], Name) Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [XidUnionElem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [XidUnionElem]
types
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Name -> [XidUnionElem] -> XDecl
forall typ. Name -> [GenXidUnionElem typ] -> GenXDecl typ
XidUnion Name
name [XidUnionElem]
types

xidUnionElem :: Element -> Maybe XidUnionElem
xidUnionElem :: Element -> Maybe XidUnionElem
xidUnionElem Element
el = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Bool
`named` Name
"type"
  XidUnionElem -> Maybe XidUnionElem
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XidUnionElem -> Maybe XidUnionElem)
-> XidUnionElem -> Maybe XidUnionElem
forall a b. (a -> b) -> a -> b
$ Type -> XidUnionElem
forall typ. typ -> GenXidUnionElem typ
XidUnionElem (Type -> XidUnionElem) -> Type -> XidUnionElem
forall a b. (a -> b) -> a -> b
$ Name -> Type
mkType (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Element -> Name
strContent Element
el

xtypedef :: Element -> Parse XDecl
xtypedef :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xtypedef Element
el = do
  Type
oldtyp <- (Name -> Type)
-> Parse Name -> ReaderT ([XHeader], Name) Maybe Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType (Parse Name -> ReaderT ([XHeader], Name) Maybe Type)
-> Parse Name -> ReaderT ([XHeader], Name) Maybe Type
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"oldname"
  Name
newname <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"newname"
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Name -> Type -> XDecl
forall typ. Name -> typ -> GenXDecl typ
XTypeDef Name
newname Type
oldtyp

xeventstruct :: Element -> Parse XDecl
xeventstruct :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xeventstruct Element
el = do
  Name
name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  [AllowedEvent]
allowed <- (Element -> ReaderT ([XHeader], Name) Maybe AllowedEvent)
-> [Element] -> ReaderT ([XHeader], Name) Maybe [AllowedEvent]
forall (f :: * -> *) a b.
Alternative f =>
(a -> f b) -> [a] -> f [b]
mapAlt Element -> ReaderT ([XHeader], Name) Maybe AllowedEvent
forall (m :: * -> *).
(MonadPlus m, Functor m) =>
Element -> m AllowedEvent
allowedEvent ([Element] -> ReaderT ([XHeader], Name) Maybe [AllowedEvent])
-> [Element] -> ReaderT ([XHeader], Name) Maybe [AllowedEvent]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
  XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a. a -> ReaderT ([XHeader], Name) Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecl -> ReaderT ([XHeader], Name) Maybe XDecl)
-> XDecl -> ReaderT ([XHeader], Name) Maybe XDecl
forall a b. (a -> b) -> a -> b
$ Name -> [AllowedEvent] -> XDecl
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 Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  Bool
xge <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"xge" m Name -> (Name -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m Bool
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
  Int
opMin <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"opcode-min" m Name -> (Name -> m Int) -> m Int
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
  Int
opMax <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"opcode-max" m Name -> (Name -> m Int) -> m Int
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
  AllowedEvent -> m AllowedEvent
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AllowedEvent -> m AllowedEvent) -> AllowedEvent -> m AllowedEvent
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 <- (Name -> Type) -> m Name -> m Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType (m Name -> m Type) -> m Name -> m Type
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"type"
        let enum :: Maybe Type
enum = (Name -> Type) -> Maybe Name -> Maybe Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType (Maybe Name -> Maybe Type) -> Maybe Name -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"enum"
        let mask :: Maybe Type
mask = (Name -> Type) -> Maybe Name -> Maybe Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType (Maybe Name -> Maybe Type) -> Maybe Name -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"mask"
        Name
name <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
        GenStructElem Type -> m (GenStructElem Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStructElem Type -> m (GenStructElem Type))
-> GenStructElem Type -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Maybe Type -> Maybe Type -> GenStructElem Type
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 = (Int -> GenStructElem typ)
-> Maybe Int -> Maybe (GenStructElem typ)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PadType -> Int -> GenStructElem typ
forall typ. PadType -> Int -> GenStructElem typ
Pad PadType
PadBytes) (Maybe Int -> Maybe (GenStructElem typ))
-> Maybe Int -> Maybe (GenStructElem typ)
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"bytes" Maybe Name -> (Name -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
        let align :: Maybe (GenStructElem typ)
align = (Int -> GenStructElem typ)
-> Maybe Int -> Maybe (GenStructElem typ)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PadType -> Int -> GenStructElem typ
forall typ. PadType -> Int -> GenStructElem typ
Pad PadType
PadAlignment) (Maybe Int -> Maybe (GenStructElem typ))
-> Maybe Int -> Maybe (GenStructElem typ)
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"align" Maybe Name -> (Name -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM

        GenStructElem Type -> m (GenStructElem Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStructElem Type -> m (GenStructElem Type))
-> GenStructElem Type -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ [GenStructElem Type] -> GenStructElem Type
forall a. HasCallStack => [a] -> a
head ([GenStructElem Type] -> GenStructElem Type)
-> [GenStructElem Type] -> GenStructElem Type
forall a b. (a -> b) -> a -> b
$ [Maybe (GenStructElem Type)] -> [GenStructElem Type]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (GenStructElem Type)] -> [GenStructElem Type])
-> [Maybe (GenStructElem Type)] -> [GenStructElem Type]
forall a b. (a -> b) -> a -> b
$ [Maybe (GenStructElem Type)
forall {typ}. Maybe (GenStructElem typ)
bytes, Maybe (GenStructElem Type)
forall {typ}. Maybe (GenStructElem typ)
align]

    | Element
el Element -> Name -> Bool
`named` Name
"list" = do
        Type
typ <- (Name -> Type) -> m Name -> m Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType (m Name -> m Type) -> m Name -> m Type
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"type"
        Name
name <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
        let enum :: Maybe Type
enum = (Name -> Type) -> Maybe Name -> Maybe Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType (Maybe Name -> Maybe Type) -> Maybe Name -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"enum"
        let expr :: Maybe XExpression
expr = Element -> Maybe Element
forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el Maybe Element
-> (Element -> Maybe XExpression) -> Maybe XExpression
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> Maybe XExpression
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
        GenStructElem Type -> m (GenStructElem Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStructElem Type -> m (GenStructElem Type))
-> GenStructElem Type -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ Name
-> Type -> Maybe XExpression -> Maybe Type -> GenStructElem Type
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 <- (Name -> Type) -> m Name -> m Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType (m Name -> m Type) -> m Name -> m Type
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"value-mask-type"
        Name
mask_name <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"value-mask-name"
        let mask_pad :: Maybe Int
mask_pad = Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"value-mask-pad" Maybe Name -> (Name -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM
        Name
list_name <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"value-list-name"
        GenStructElem Type -> m (GenStructElem Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStructElem Type -> m (GenStructElem Type))
-> GenStructElem Type -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ Type -> Name -> Maybe Int -> Name -> GenStructElem Type
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 Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
        (Element
exprEl,[Element]
caseEls) <- Element -> m (Element, [Element])
forall (m :: * -> *).
MonadPlus m =>
Element -> m (Element, [Element])
unconsChildren Element
el
        XExpression
expr <- Element -> m XExpression
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression Element
exprEl
        (Maybe Alignment
alignment, [Element]
xs) <- [Element] -> m (Maybe Alignment, [Element])
forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment ([Element] -> m (Maybe Alignment, [Element]))
-> [Element] -> m (Maybe Alignment, [Element])
forall a b. (a -> b) -> a -> b
$ [Element]
caseEls
        [BitCase]
cases <- (Element -> m BitCase) -> [Element] -> m [BitCase]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> m BitCase
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m BitCase
bitCase [Element]
xs
        GenStructElem Type -> m (GenStructElem Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStructElem Type -> m (GenStructElem Type))
-> GenStructElem Type -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ Name
-> XExpression
-> Maybe Alignment
-> [BitCase]
-> GenStructElem Type
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 <- (Name -> Type) -> m Name -> m Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Name -> Type
mkType (m Name -> m Type) -> m Name -> m Type
forall a b. (a -> b) -> a -> b
$ Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"type"
        Name
name <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
        XExpression
expr <- Element -> m Element
forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el m Element -> (Element -> m XExpression) -> m XExpression
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> m XExpression
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
        GenStructElem Type -> m (GenStructElem Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStructElem Type -> m (GenStructElem Type))
-> GenStructElem Type -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ Name -> Type -> XExpression -> GenStructElem Type
forall typ. Name -> typ -> Expression typ -> GenStructElem typ
ExprField Name
name Type
typ XExpression
expr

    | Element
el Element -> Name -> Bool
`named` Name
"reply" = Name -> m (GenStructElem Type)
forall a. Name -> m a
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 Element -> Name -> m [Element]
forall (m :: * -> *). MonadPlus m => Element -> Name -> m [Element]
`children` Name
"field"
        let mkField :: Element -> Maybe (Name, Name)
mkField = \Element
x -> (Name -> (Name, Name)) -> Maybe Name -> Maybe (Name, Name)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
y -> (Name
y, Element -> Name
strContent Element
x)) (Maybe Name -> Maybe (Name, Name))
-> Maybe Name -> Maybe (Name, Name)
forall a b. (a -> b) -> a -> b
$ Element
x Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
            fields' :: Map Name Name
fields' = [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Name)] -> Map Name Name)
-> [(Name, Name)] -> Map Name Name
forall a b. (a -> b) -> a -> b
$ [Maybe (Name, Name)] -> [(Name, Name)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Name, Name)] -> [(Name, Name)])
-> [Maybe (Name, Name)] -> [(Name, Name)]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe (Name, Name))
-> [Element] -> [Maybe (Name, Name)]
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' = [Maybe (Name, Name)] -> [(Name, Name)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Name, Name)] -> [(Name, Name)])
-> [Maybe (Name, Name)] -> [(Name, Name)]
forall a b. (a -> b) -> a -> b
$ ((Element -> Maybe (Name, Name))
 -> [Element] -> [Maybe (Name, Name)])
-> [Element]
-> (Element -> Maybe (Name, Name))
-> [Maybe (Name, Name)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Element -> Maybe (Name, Name))
-> [Element] -> [Maybe (Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map [Element]
sees ((Element -> Maybe (Name, Name)) -> [Maybe (Name, Name)])
-> (Element -> Maybe (Name, Name)) -> [Maybe (Name, Name)]
forall a b. (a -> b) -> a -> b
$ \Element
s -> do Name
typ <- Element
s Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"type"
                                                         Name
name <- Element
s Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
                                                         (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
typ, Name
name)
            brief :: Maybe Name
brief = (Element -> Name) -> Maybe Element -> Maybe Name
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> Name
strContent (Maybe Element -> Maybe Name) -> Maybe Element -> Maybe Name
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe Element
findChild (Name -> QName
unqual Name
"brief") Element
el
        GenStructElem Type -> m (GenStructElem Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStructElem Type -> m (GenStructElem Type))
-> GenStructElem Type -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ Maybe Name -> Map Name Name -> [(Name, Name)] -> GenStructElem Type
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 Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
        GenStructElem Type -> m (GenStructElem Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStructElem Type -> m (GenStructElem Type))
-> GenStructElem Type -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ Name -> GenStructElem Type
forall typ. Name -> GenStructElem typ
Fd Name
name

    | Element
el Element -> Name -> Bool
`named` Name
"length" = do
        XExpression
expr <- Element -> m Element
forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el m Element -> (Element -> m XExpression) -> m XExpression
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> m XExpression
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
        let typ :: Type
typ = Name -> Type
mkType Name
"CARD32"
        GenStructElem Type -> m (GenStructElem Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStructElem Type -> m (GenStructElem Type))
-> GenStructElem Type -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ Type -> XExpression -> GenStructElem Type
forall typ. typ -> Expression typ -> GenStructElem typ
Length Type
typ XExpression
expr

    | Bool
otherwise = let name :: QName
name = Element -> QName
elName Element
el
                  in Name -> m (GenStructElem Type)
forall a. HasCallStack => Name -> a
error (Name -> m (GenStructElem Type)) -> Name -> m (GenStructElem Type)
forall a b. (a -> b) -> a -> b
$ Name
"I don't know what to do with structelem "
 Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ QName -> Name
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 Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
              let ([Element]
exprEls, [Element]
fieldEls) = [Element] -> ([Element], [Element])
takeEnumrefs ([Element] -> ([Element], [Element]))
-> [Element] -> ([Element], [Element])
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
              [XExpression]
exprs <- (Element -> m XExpression) -> [Element] -> m [XExpression]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> m XExpression
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression [Element]
exprEls
              (Maybe Alignment
alignment, [Element]
xs) <- [Element] -> m (Maybe Alignment, [Element])
forall (m :: * -> *).
(MonadPlus m, Functor m) =>
[Element] -> m (Maybe Alignment, [Element])
extractAlignment ([Element] -> m (Maybe Alignment, [Element]))
-> [Element] -> m (Maybe Alignment, [Element])
forall a b. (a -> b) -> a -> b
$ [Element]
fieldEls
              [GenStructElem Type]
fields <- (Element -> m (GenStructElem Type))
-> [Element] -> m [GenStructElem Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> m (GenStructElem Type)
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField [Element]
xs
              BitCase -> m BitCase
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BitCase -> m BitCase) -> BitCase -> m BitCase
forall a b. (a -> b) -> a -> b
$ Maybe Name
-> [XExpression]
-> Maybe Alignment
-> [GenStructElem Type]
-> BitCase
forall typ.
Maybe Name
-> [Expression typ]
-> Maybe Alignment
-> [GenStructElem typ]
-> GenBitCase typ
BitCase Maybe Name
mName [XExpression]
exprs Maybe Alignment
alignment [GenStructElem Type]
fields
           | Bool
otherwise =
              let name :: QName
name = Element -> QName
elName Element
el
              in Name -> m BitCase
forall a. HasCallStack => Name -> a
error (Name -> m BitCase) -> Name -> m BitCase
forall a b. (a -> b) -> a -> b
$ Name
"Invalid bitCase: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ QName -> Name
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"
                    = XExpression -> m XExpression
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExpression -> m XExpression) -> XExpression -> m XExpression
forall a b. (a -> b) -> a -> b
$ Name -> XExpression
forall typ. Name -> Expression typ
FieldRef (Name -> XExpression) -> Name -> XExpression
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 (Name -> Type) -> m Name -> m Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"ref"
                   let enumVal :: Name
enumVal = Element -> Name
strContent Element
el
                   Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Name
enumVal Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
""
                   XExpression -> m XExpression
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExpression -> m XExpression) -> XExpression -> m XExpression
forall a b. (a -> b) -> a -> b
$ Type -> Name -> XExpression
forall typ. typ -> Name -> Expression typ
EnumRef Type
enumTy Name
enumVal
              | Element
el Element -> Name -> Bool
`named` Name
"value"
                    = Int -> XExpression
forall typ. Int -> Expression typ
Value (Int -> XExpression) -> m Int -> m XExpression
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Name -> m Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM (Element -> Name
strContent Element
el)
              | Element
el Element -> Name -> Bool
`named` Name
"bit"
                    = Int -> XExpression
forall typ. Int -> Expression typ
Bit (Int -> XExpression) -> m Int -> m XExpression
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` do
                        Int
n <- Name -> m Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM (Element -> Name
strContent Element
el)
                        Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
                        Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
              | Element
el Element -> Name -> Bool
`named` Name
"op" = do
                    Binop
binop <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"op" m Name -> (Name -> m Binop) -> m Binop
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m Binop
forall (m :: * -> *). MonadPlus m => Name -> m Binop
toBinop
                    [XExpression
exprLhs,XExpression
exprRhs] <- (Element -> m XExpression) -> [Element] -> m [XExpression]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> m XExpression
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression ([Element] -> m [XExpression]) -> [Element] -> m [XExpression]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
el
                    XExpression -> m XExpression
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExpression -> m XExpression) -> XExpression -> m XExpression
forall a b. (a -> b) -> a -> b
$ Binop -> XExpression -> XExpression -> XExpression
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 Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"op" m Name -> (Name -> m Unop) -> m Unop
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m Unop
forall (m :: * -> *). MonadPlus m => Name -> m Unop
toUnop
                    XExpression
expr <- Element -> m Element
forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el m Element -> (Element -> m XExpression) -> m XExpression
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> m XExpression
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
                    XExpression -> m XExpression
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExpression -> m XExpression) -> XExpression -> m XExpression
forall a b. (a -> b) -> a -> b
$ Unop -> XExpression -> XExpression
forall typ. Unop -> Expression typ -> Expression typ
Unop Unop
op XExpression
expr
              | Element
el Element -> Name -> Bool
`named` Name
"popcount" = do
                    XExpression
expr <- Element -> m Element
forall (m :: * -> *). MonadPlus m => Element -> m Element
firstChild Element
el m Element -> (Element -> m XExpression) -> m XExpression
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> m XExpression
forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m XExpression
expression
                    XExpression -> m XExpression
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExpression -> m XExpression) -> XExpression -> m XExpression
forall a b. (a -> b) -> a -> b
$ XExpression -> XExpression
forall typ. Expression typ -> Expression typ
PopCount XExpression
expr
              | Element
el Element -> Name -> Bool
`named` Name
"sumof" = do
                    Name
ref <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"ref"
                    XExpression -> m XExpression
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExpression -> m XExpression) -> XExpression -> m XExpression
forall a b. (a -> b) -> a -> b
$ Name -> XExpression
forall typ. Name -> Expression typ
SumOf Name
ref
              | Element
el Element -> Name -> Bool
`named` Name
"paramref"
                    =  XExpression -> m XExpression
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExpression -> m XExpression) -> XExpression -> m XExpression
forall a b. (a -> b) -> a -> b
$ Name -> XExpression
forall typ. Name -> Expression typ
ParamRef (Name -> XExpression) -> Name -> XExpression
forall a b. (a -> b) -> a -> b
$ Element -> Name
strContent Element
el
              | Bool
otherwise =
                  let nm :: QName
nm = Element -> QName
elName Element
el
                  in Name -> m XExpression
forall a. HasCallStack => Name -> a
error (Name -> m XExpression) -> Name -> m XExpression
forall a b. (a -> b) -> a -> b
$ Name
"Unknown epression " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ QName -> Name
forall a. Show a => a -> Name
show QName
nm Name -> Name -> Name
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
"+"  = Binop -> m Binop
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Binop
Add
toBinop Name
"-"  = Binop -> m Binop
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Binop
Sub
toBinop Name
"*"  = Binop -> m Binop
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Binop
Mult
toBinop Name
"/"  = Binop -> m Binop
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Binop
Div
toBinop Name
"&"  = Binop -> m Binop
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Binop
And
toBinop Name
"&amp;" = Binop -> m Binop
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Binop
And
toBinop Name
">>" = Binop -> m Binop
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Binop
RShift
toBinop Name
_ = m Binop
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

toUnop :: MonadPlus m => String -> m Unop
toUnop :: forall (m :: * -> *). MonadPlus m => Name -> m Unop
toUnop Name
"~" = Unop -> m Unop
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop
Complement
toUnop Name
_ = m Unop
forall a. m a
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 = [Element] -> m Element
forall (m :: * -> *) a. MonadPlus m => [a] -> m a
listToM ([Element] -> m Element)
-> (Element -> [Element]) -> Element -> m Element
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) -> (Element, [Element]) -> m (Element, [Element])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Element
x,[Element]
xs)
        [Element]
_ -> m (Element, [Element])
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

takeEnumrefs :: [Element] -> ([Element], [Element])
takeEnumrefs :: [Element] -> ([Element], [Element])
takeEnumrefs [] = ([], [])
takeEnumrefs (Element
x:[Element]
xs) =
    let ([Element]
ys, [Element]
zs) = [Element] -> ([Element], [Element])
takeEnumrefs [Element]
xs
    in if Element
x Element -> Name -> Bool
`named` Name
"enumref" then (Element
xElement -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:[Element]
ys, [Element]
zs) else ([Element]
ys, Element
xElement -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:[Element]
zs)

listToM :: MonadPlus m => [a] -> m a
listToM :: forall (m :: * -> *) a. MonadPlus m => [a] -> m a
listToM [] = m a
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
listToM (a
x:[a]
_) = a -> m a
forall a. a -> m 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 QName -> QName -> Bool
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 (Attr -> Bool) -> [Attr] -> Maybe Attr
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Attr -> Bool
p [Attr]
xs of
      Just (Attr QName
_ Name
res) -> Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
res
      Maybe Attr
_ -> m Name
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    where p :: Attr -> Bool
p (Attr QName
qname Name
_) | QName
qname QName -> QName -> Bool
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 (Content -> Bool) -> [Content] -> [Content]
forall a. (a -> Bool) -> [a] -> [a]
List.filter Content -> Bool
p [Content]
xs of
      [] -> m [Element]
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      [Content]
some -> [Element] -> m [Element]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Element] -> m [Element]) -> [Element] -> m [Element]
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 QName -> QName -> Bool
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 = ((a, Name) -> a) -> m (a, Name) -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a, Name) -> a
forall a b. (a, b) -> a
fst (m (a, Name) -> m a) -> (Name -> m (a, Name)) -> Name -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Name)] -> m (a, Name)
forall (m :: * -> *) a. MonadPlus m => [a] -> m a
listToM ([(a, Name)] -> m (a, Name))
-> (Name -> [(a, Name)]) -> Name -> m (a, Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [(a, Name)]
forall a. Read a => ReadS a
reads