-- |
-- 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
  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
  return $ fromStrings strings

-- | Like 'readFile', but forces the encoding
-- of the file to UTF8.
readFileUTF8 :: FilePath -> IO String
readFileUTF8 :: Name -> IO Name
readFileUTF8 Name
fp = do
  h <- Name -> IOMode -> IO Handle
openFile Name
fp IOMode
ReadMode
  hSetEncoding h utf8
  hGetContents h

-- |Process the strings as if they were XML files.
-- Any files which fail to parse are silently dropped.
-- Any declaration in an XML file which fail to parse are
-- silently dropped.
fromStrings :: [String] -> [XHeader]
fromStrings :: [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
                               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
                               offset <- el `attr` "offset" >>= readM
                               return (Just (Alignment align offset), 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
  lname <- Parse Name
localName
  liftM2 mplus (lookupThingy f $ Just lname)
               (lookupThingy f $ Just "xproto") -- implicit xproto import
lookupThingy [XDecl] -> Maybe a
f (Just Name
mname) = do
  xs <- Parse [XHeader]
allModules
  return $ do
    x <- findXHeader mname xs
    f $ xheader_decls x

-- lookup an event declaration by name.
lookupEvent :: Maybe Name -> Name -> Parse (Maybe EventDetails)
lookupEvent :: 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 _qname _ats cnt _) <- 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
  guard $ el `named` "xcb"
  header <- el `attr` "header"
  let name = Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"extension-name"
      xname = Element
el Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"extension-xname"
      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 = 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 = 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
  decls <- withReaderT (\[XHeader]
r -> ([XHeader]
r,Name
header)) $ extractDecls cnt
  return $ XHeader {xheader_header = header
                   ,xheader_xname = xname
                   ,xheader_name = name
                   ,xheader_multiword = multiword
                   ,xheader_major_version = maj_ver
                   ,xheader_minor_version = min_ver
                   ,xheader_decls = decls
                   }

-- attempts to extract declarations from XML content, discarding failures.
extractDecls :: [Content] -> Parse [XDecl]
extractDecls :: [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
  nm <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  fields <- mapAlt enumField $ elChildren el
  guard $ not $ null fields
  return $ XEnum nm 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 <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  let 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
  return $ EnumElem name expr

xrequest :: Element -> Parse XDecl
xrequest :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xrequest Element
el = do
  nm <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  code <- el `attr` "opcode" >>= readM
  -- TODO - I don't think I like 'mapAlt' here.
  -- I don't want to be silently dropping fields
  (alignment, xs) <- extractAlignment $ elChildren el
  fields <- mapAlt structField $ xs
  let reply = Element -> Maybe XReply
getReply Element
el
  return $ XRequest nm code alignment fields reply

getReply :: Element -> Maybe XReply
getReply :: Element -> Maybe XReply
getReply Element
el = do
  childElem <- Name -> QName
unqual Name
"reply" QName -> Element -> Maybe Element
`findChild` Element
el
  (alignment, xs) <- extractAlignment $ elChildren childElem
  fields <- mapM structField xs
  guard $ not $ null fields
  return $ GenXReply alignment fields

xevent :: Element -> Parse XDecl
xevent :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xevent Element
el = do
  name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  number <- el `attr` "number" >>= readM
  let 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 = 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
  (alignment, xs) <- extractAlignment (elChildren el)
  fields <- mapM structField $ xs
  guard $ not $ null fields
  return $ XEvent name number alignment xge fields noseq

xevcopy :: Element -> Parse XDecl
xevcopy :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xevcopy Element
el = do
  name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  number <- el `attr` "number" >>= readM
  ref <- el `attr` "ref"
  -- do we have a qualified ref?
  let (mname,evname) = splitRef ref
  details <- lookupEvent mname evname
  return $ let EventDetails _ _ alignment xge fields noseq =
                 case details of
                   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 XEvent name number alignment xge fields 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 <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  number <- el `attr` "number" >>= readM
  (alignment, xs) <- extractAlignment $ elChildren el
  fields <- mapM structField $ xs
  return $ XError name number alignment fields


xercopy :: Element -> Parse XDecl
xercopy :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xercopy Element
el = do
  name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  number <- el `attr` "number" >>= readM
  ref <- el `attr` "ref"
  let (mname, ername) = splitRef ref
  details <- lookupError mname ername
  return $ uncurry (XError name number) $ case details of
               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 <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  (alignment, xs) <- extractAlignment $ elChildren el
  fields <- mapAlt structField $ xs
  guard $ not $ null fields
  return $ XStruct name alignment fields

xunion :: Element -> Parse XDecl
xunion :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xunion Element
el = do
  name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  (alignment, xs) <- extractAlignment $ elChildren el
  fields <- mapAlt structField $ xs
  guard $ not $ null fields
  return $ XUnion name alignment 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 <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  let 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
  guard $ not $ null types
  return $ XidUnion name 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
  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"
  newname <- el `attr` "newname"
  return $ XTypeDef newname oldtyp

xeventstruct :: Element -> Parse XDecl
xeventstruct :: Element -> ReaderT ([XHeader], Name) Maybe XDecl
xeventstruct Element
el = do
  name <- Element
el Element -> Name -> Parse Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  allowed <- mapAlt allowedEvent $ elChildren el
  return $ XEventStruct name allowed

allowedEvent :: (MonadPlus m, Functor m) => Element -> m AllowedEvent
allowedEvent :: forall (m :: * -> *).
(MonadPlus m, Functor m) =>
Element -> m AllowedEvent
allowedEvent Element
el = do
  extension <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
  xge <- el `attr` "xge" >>= readM
  opMin <- el `attr` "opcode-min" >>= readM
  opMax <- el `attr` "opcode-max" >>= readM
  return $ AllowedEvent extension xge opMin opMax

structField :: (MonadFail m, MonadPlus m, Functor m) => Element -> m StructElem
structField :: forall (m :: * -> *).
(MonadFail m, MonadPlus m, Functor m) =>
Element -> m (GenStructElem Type)
structField Element
el
    | Element
el Element -> Name -> Bool
`named` Name
"field" = do
        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 = (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 = (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 <- el `attr` "name"
        return $ SField name typ enum 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
        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 <- el `attr` "name"
        let 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 = 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
        return $ List name typ expr enum

    | Element
el Element -> Name -> Bool
`named` Name
"valueparam" = do
        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"
        mask_name <- el `attr` "value-mask-name"
        let 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
        list_name <- el `attr` "value-list-name"
        return $ ValueParam mask_typ mask_name mask_pad list_name

    | Element
el Element -> Name -> Bool
`named` Name
"switch" = do
        nm <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
        (exprEl,caseEls) <- unconsChildren el
        expr <- expression exprEl
        (alignment, xs) <- extractAlignment $ caseEls
        cases <- mapM bitCase xs
        return $ Switch nm expr alignment cases

    | Element
el Element -> Name -> Bool
`named` Name
"exprfield" = do
        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 <- el `attr` "name"
        expr <- firstChild el >>= expression
        return $ ExprField name typ 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
        fields <- Element
el Element -> Name -> m [Element]
forall (m :: * -> *). MonadPlus m => Element -> Name -> m [Element]
`children` Name
"field"
        let 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' = [(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 = QName -> Element -> [Element]
findChildren (Name -> QName
unqual Name
"see") Element
el
            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 typ <- Element
s Element -> Name -> Maybe Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"type"
                                                         name <- s `attr` "name"
                                                         return (typ, 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
        return $ Doc brief fields' sees'

    | Element
el Element -> Name -> Bool
`named` Name
"fd" = do
        name <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"name"
        return $ Fd name

    | Element
el Element -> Name -> Bool
`named` Name
"length" = do
        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 = Name -> Type
mkType Name
"CARD32"
        return $ Length typ 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"
              (exprEl, fieldEls) <- Element -> m (Element, [Element])
forall (m :: * -> *).
MonadPlus m =>
Element -> m (Element, [Element])
unconsChildren Element
el
              expr <- expression exprEl
              (alignment, xs) <- extractAlignment $ fieldEls
              fields <- mapM structField xs
              return $ BitCase mName expr alignment 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
                   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 = Element -> Name
strContent Element
el
                   guard $ enumVal /= ""
                   return $ EnumRef enumTy 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
                        n <- Name -> m Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Name -> m a
readM (Element -> Name
strContent Element
el)
                        guard $ n >= 0
                        return n
              | Element
el Element -> Name -> Bool
`named` Name
"op" = do
                    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
                    [exprLhs,exprRhs] <- mapM expression $ elChildren el
                    return $ Op binop exprLhs exprRhs
              | Element
el Element -> Name -> Bool
`named` Name
"unop" = do
                    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
                    expr <- firstChild el >>= expression
                    return $ Unop op expr
              | Element
el Element -> Name -> Bool
`named` Name
"popcount" = do
                    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
                    return $ PopCount expr
              | Element
el Element -> Name -> Bool
`named` Name
"sumof" = do
                    ref <- Element
el Element -> Name -> m Name
forall (m :: * -> *). MonadPlus m => Element -> Name -> m Name
`attr` Name
"ref"
                    return $ SumOf 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

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