module Network.DBus.Model.Parse
( fromXML
) where
import Control.Applicative
import Text.XML.Light
import qualified Network.DBus.Actions as DBus (unserializeSignature)
import Network.DBus.Model.Types
import qualified Data.ByteString.Char8 as BC
import Data.List (partition)
fromXML :: String -> Maybe Model
fromXML s = el >>= parseNode
where el = parseXMLDoc s
tpNS = Just "tp"
parseNode :: Element -> Maybe Model
parseNode e = Model <$> mapM parseInterface (childElems "interface" e)
<*> attr "name" e
<*> pure (attrFQ (Just "xmlns") "tp" e)
parseInterface e =
Interface <$> parseName e
<*> mapM parseMethod (childElems "method" e)
<*> mapM parseSignal (childElems "signal" e)
<*> mapM parseProperty (childElems "property" e)
<*> mapM parseEnumeration (childElemsFQ tpNS "enum" e)
<*> mapM parseFlags (childElemsFQ tpNS "flags" e)
<*> mapM parseStruct (childElemsFQ tpNS "struct" e)
parseStruct e =
Struct <$> parseName e
<*> mapM parseMember (childElemsFQ tpNS "member" e)
parseMember e =
Member <$> parseName e
<*> parseType e
<*> pure (parseRawType e)
<*> parseDoc e
parseEnumeration e =
Enumeration <$> parseName e
<*> parseType e
<*> mapM parseEnumValue (childElemsFQ tpNS "enumvalue" e)
parseEnumValue e =
EnumValue <$> attr "suffix" e
<*> attr "value" e
parseFlags e =
Flags <$> parseName e
<*> attr "value-prefix" e
<*> parseType e
<*> mapM parseFlag (childElemsFQ tpNS "flag" e)
<*> parseDoc e
parseFlag e =
Flag <$> attr "suffix" e
<*> attr "value" e
<*> parseDoc e
parseProperty e =
Property <$> parseName e
<*> parseType e
<*> parseAccess e
<*> pure (parseRawType e)
parseMethod e =
Method <$> parseName e
<*> mapM parseAnnotation (childElems "annotation" e)
<*> mapM parseArg inElems
<*> mapM parseArg outElems
<*> parseDoc e
where argElems = childElems "arg" e
(inElems,outElems) = partition inOrOut argElems
inOrOut a = case attr "direction" a of
Nothing -> True
Just "in" -> True
Just "out" -> False
Just z -> error ("unexpected direction string: " ++ z)
parseSignal e =
Signal <$> parseName e
<*> mapM parseArg (childElems "arg" e)
<*> parseDoc e
parseAnnotation e =
Annotation <$> parseName e
<*> attr "value" e
parseArg e =
Arg <$> parseName e
<*> parseType e
<*> parseDoc e
parseType e = attr "type" e >>= parseSignature
where parseSignature s = do
typsig <- either (const Nothing) Just $ DBus.unserializeSignature (BC.pack s)
case typsig of
[t] -> Just t
_ -> Nothing
parseAccess e = attr "access" e >>= parse
where parse "read" = Just Read
parse "write" = Just Write
parse "readwrite" = Just ReadWrite
parse _ = Nothing
parseRawType e = attrFQ tpNS "type" e
parseName e = attr "name" e
parseDoc e = pure $ case childElemsFQ tpNS "docstring" e of
[el] -> case elContent el of
[Text t] -> Just $ cdData t
z -> error (show z)
_ -> Nothing
childElemsFQ :: Maybe String -> String -> Element -> [Element]
childElemsFQ ns name el = filterChildren ((qnameEqNoUrl ns name) . elName) el
childElems name el = childElemsFQ Nothing name el
attrFQ :: Maybe String -> String -> Element -> Maybe String
attrFQ ns name el = lookupAttrBy (qnameEqNoUrl ns name) $ elAttribs el
attr = attrFQ Nothing
qnameEqNoUrl :: Maybe String -> String -> QName -> Bool
qnameEqNoUrl pre n qn = qName qn == n && qPrefix qn == pre