{-# LANGUAGE OverloadedStrings #-}

module DBus.Introspection.Parse
    ( parseXML
    ) where

import Conduit
import Data.Maybe
import Data.XML.Types
import qualified Data.Text as T
import qualified Text.XML.Stream.Parse as X

import DBus.Internal.Types
import DBus.Introspection.Types

data ObjectChildren
    = InterfaceDefinition Interface
    | SubNode Object

data InterfaceChildren
    = MethodDefinition Method
    | SignalDefinition Signal
    | PropertyDefinition Property

parseXML :: ObjectPath -> T.Text -> Maybe Object
parseXML :: ObjectPath -> Text -> Maybe Object
parseXML ObjectPath
path Text
xml =
    ConduitT () Void Maybe Object -> Maybe Object
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void Maybe Object -> Maybe Object)
-> ConduitT () Void Maybe Object -> Maybe Object
forall a b. (a -> b) -> a -> b
$ [Text] -> ConduitT () (Element [Text]) Maybe ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [Text
xml] ConduitT () Text Maybe ()
-> ConduitM Text Void Maybe Object -> ConduitT () Void Maybe Object
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ParseSettings -> ConduitT Text Event Maybe ()
forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT Text Event m ()
X.parseText ParseSettings
forall a. Default a => a
X.def ConduitT Text Event Maybe ()
-> ConduitM Event Void Maybe Object
-> ConduitM Text Void Maybe Object
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| String
-> ConduitT Event Void Maybe (Maybe Object)
-> ConduitM Event Void Maybe Object
forall (m :: * -> *) a.
MonadThrow m =>
String -> m (Maybe a) -> m a
X.force String
"parse error" (AttrParser ObjectPath -> ConduitT Event Void Maybe (Maybe Object)
forall o.
AttrParser ObjectPath -> ConduitT Event o Maybe (Maybe Object)
parseObject (AttrParser ObjectPath -> ConduitT Event Void Maybe (Maybe Object))
-> AttrParser ObjectPath
-> ConduitT Event Void Maybe (Maybe Object)
forall a b. (a -> b) -> a -> b
$ ObjectPath -> AttrParser ObjectPath
getRootName ObjectPath
path)

getRootName :: ObjectPath -> X.AttrParser ObjectPath
getRootName :: ObjectPath -> AttrParser ObjectPath
getRootName ObjectPath
defaultPath = do
    Maybe Text
nodeName <- Name -> AttrParser (Maybe Text)
X.attr Name
"name"
    ObjectPath -> AttrParser ObjectPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectPath -> AttrParser ObjectPath)
-> ObjectPath -> AttrParser ObjectPath
forall a b. (a -> b) -> a -> b
$ ObjectPath -> (Text -> ObjectPath) -> Maybe Text -> ObjectPath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ObjectPath
defaultPath (String -> ObjectPath
objectPath_ (String -> ObjectPath) -> (Text -> String) -> Text -> ObjectPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) Maybe Text
nodeName

getChildName :: ObjectPath -> X.AttrParser ObjectPath
getChildName :: ObjectPath -> AttrParser ObjectPath
getChildName ObjectPath
parentPath = do
    Text
nodeName <- Name -> AttrParser Text
X.requireAttr Name
"name"
    let parentPath' :: String
parentPath' = case ObjectPath -> String
formatObjectPath ObjectPath
parentPath of
            String
"/" -> String
"/"
            String
x   -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
    ObjectPath -> AttrParser ObjectPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectPath -> AttrParser ObjectPath)
-> ObjectPath -> AttrParser ObjectPath
forall a b. (a -> b) -> a -> b
$ String -> ObjectPath
objectPath_ (String
parentPath' String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
nodeName)

parseObject
    :: X.AttrParser ObjectPath
    -> ConduitT Event o Maybe (Maybe Object)
parseObject :: AttrParser ObjectPath -> ConduitT Event o Maybe (Maybe Object)
parseObject AttrParser ObjectPath
getPath = NameMatcher Name
-> AttrParser ObjectPath
-> (ObjectPath -> ConduitT Event o Maybe Object)
-> ConduitT Event o Maybe (Maybe Object)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
X.tag' NameMatcher Name
"node" AttrParser ObjectPath
getPath ObjectPath -> ConduitT Event o Maybe Object
forall o. ObjectPath -> ConduitT Event o Maybe Object
parseContent
  where
    parseContent :: ObjectPath -> ConduitT Event o Maybe Object
parseContent ObjectPath
objPath = do
        [ObjectChildren]
elems <- ConduitT Event o Maybe (Maybe ObjectChildren)
-> ConduitT Event o Maybe [ObjectChildren]
forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
X.many (ConduitT Event o Maybe (Maybe ObjectChildren)
 -> ConduitT Event o Maybe [ObjectChildren])
-> ConduitT Event o Maybe (Maybe ObjectChildren)
-> ConduitT Event o Maybe [ObjectChildren]
forall a b. (a -> b) -> a -> b
$ [ConduitT Event o Maybe (Maybe ObjectChildren)]
-> ConduitT Event o Maybe (Maybe ObjectChildren)
forall (m :: * -> *) o a.
Monad m =>
[ConduitT Event o m (Maybe a)] -> ConduitT Event o m (Maybe a)
X.choose
            [ (Object -> ObjectChildren) -> Maybe Object -> Maybe ObjectChildren
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Object -> ObjectChildren
SubNode (Maybe Object -> Maybe ObjectChildren)
-> ConduitT Event o Maybe (Maybe Object)
-> ConduitT Event o Maybe (Maybe ObjectChildren)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttrParser ObjectPath -> ConduitT Event o Maybe (Maybe Object)
forall o.
AttrParser ObjectPath -> ConduitT Event o Maybe (Maybe Object)
parseObject (ObjectPath -> AttrParser ObjectPath
getChildName ObjectPath
objPath)
            , (Interface -> ObjectChildren)
-> Maybe Interface -> Maybe ObjectChildren
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Interface -> ObjectChildren
InterfaceDefinition (Maybe Interface -> Maybe ObjectChildren)
-> ConduitT Event o Maybe (Maybe Interface)
-> ConduitT Event o Maybe (Maybe ObjectChildren)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Event o Maybe (Maybe Interface)
forall o. ConduitT Event o Maybe (Maybe Interface)
parseInterface
            ]
        let base :: Object
base = ObjectPath -> [Interface] -> [Object] -> Object
Object ObjectPath
objPath [] []
            addElem :: ObjectChildren -> Object -> Object
addElem ObjectChildren
e (Object ObjectPath
p [Interface]
is [Object]
cs) = case ObjectChildren
e of
                InterfaceDefinition Interface
i -> ObjectPath -> [Interface] -> [Object] -> Object
Object ObjectPath
p (Interface
iInterface -> [Interface] -> [Interface]
forall a. a -> [a] -> [a]
:[Interface]
is) [Object]
cs
                SubNode Object
c -> ObjectPath -> [Interface] -> [Object] -> Object
Object ObjectPath
p [Interface]
is (Object
cObject -> [Object] -> [Object]
forall a. a -> [a] -> [a]
:[Object]
cs)
        Object -> ConduitT Event o Maybe Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> ConduitT Event o Maybe Object)
-> Object -> ConduitT Event o Maybe Object
forall a b. (a -> b) -> a -> b
$ (ObjectChildren -> Object -> Object)
-> Object -> [ObjectChildren] -> Object
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ObjectChildren -> Object -> Object
addElem Object
base [ObjectChildren]
elems

parseInterface
    :: ConduitT Event o Maybe (Maybe Interface)
parseInterface :: ConduitT Event o Maybe (Maybe Interface)
parseInterface = NameMatcher Name
-> AttrParser InterfaceName
-> (InterfaceName -> ConduitT Event o Maybe Interface)
-> ConduitT Event o Maybe (Maybe Interface)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
X.tag' NameMatcher Name
"interface" AttrParser InterfaceName
getName InterfaceName -> ConduitT Event o Maybe Interface
forall o. InterfaceName -> ConduitT Event o Maybe Interface
parseContent
  where
    getName :: AttrParser InterfaceName
getName = do
        Text
ifName <- Name -> AttrParser Text
X.requireAttr Name
"name"
        InterfaceName -> AttrParser InterfaceName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterfaceName -> AttrParser InterfaceName)
-> InterfaceName -> AttrParser InterfaceName
forall a b. (a -> b) -> a -> b
$ String -> InterfaceName
interfaceName_ (Text -> String
T.unpack Text
ifName)
    parseContent :: InterfaceName -> ConduitT Event o Maybe Interface
parseContent InterfaceName
ifName = do
        [InterfaceChildren]
elems <- ConduitT Event o Maybe (Maybe InterfaceChildren)
-> ConduitT Event o Maybe [InterfaceChildren]
forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
X.many (ConduitT Event o Maybe (Maybe InterfaceChildren)
 -> ConduitT Event o Maybe [InterfaceChildren])
-> ConduitT Event o Maybe (Maybe InterfaceChildren)
-> ConduitT Event o Maybe [InterfaceChildren]
forall a b. (a -> b) -> a -> b
$ do
            ConduitT Event o Maybe (Maybe ()) -> ConduitT Event o Maybe ()
forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ (ConduitT Event o Maybe (Maybe ()) -> ConduitT Event o Maybe ())
-> ConduitT Event o Maybe (Maybe ()) -> ConduitT Event o Maybe ()
forall a b. (a -> b) -> a -> b
$ NameMatcher Name
-> AttrParser () -> ConduitT Event o Maybe (Maybe ())
forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
            [ConduitT Event o Maybe (Maybe InterfaceChildren)]
-> ConduitT Event o Maybe (Maybe InterfaceChildren)
forall (m :: * -> *) o a.
Monad m =>
[ConduitT Event o m (Maybe a)] -> ConduitT Event o m (Maybe a)
X.choose
                [ ConduitT Event o Maybe (Maybe InterfaceChildren)
forall o. ConduitT Event o Maybe (Maybe InterfaceChildren)
parseMethod
                , ConduitT Event o Maybe (Maybe InterfaceChildren)
forall o. ConduitT Event o Maybe (Maybe InterfaceChildren)
parseSignal
                , ConduitT Event o Maybe (Maybe InterfaceChildren)
forall o. ConduitT Event o Maybe (Maybe InterfaceChildren)
parseProperty
                ]
        ConduitT Event o Maybe (Maybe ()) -> ConduitT Event o Maybe ()
forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ (ConduitT Event o Maybe (Maybe ()) -> ConduitT Event o Maybe ())
-> ConduitT Event o Maybe (Maybe ()) -> ConduitT Event o Maybe ()
forall a b. (a -> b) -> a -> b
$ NameMatcher Name
-> AttrParser () -> ConduitT Event o Maybe (Maybe ())
forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
        let base :: Interface
base = InterfaceName -> [Method] -> [Signal] -> [Property] -> Interface
Interface InterfaceName
ifName [] [] []
            addElem :: InterfaceChildren -> Interface -> Interface
addElem InterfaceChildren
e (Interface InterfaceName
n [Method]
ms [Signal]
ss [Property]
ps) = case InterfaceChildren
e of
                MethodDefinition Method
m -> InterfaceName -> [Method] -> [Signal] -> [Property] -> Interface
Interface InterfaceName
n (Method
mMethod -> [Method] -> [Method]
forall a. a -> [a] -> [a]
:[Method]
ms) [Signal]
ss [Property]
ps
                SignalDefinition Signal
s -> InterfaceName -> [Method] -> [Signal] -> [Property] -> Interface
Interface InterfaceName
n [Method]
ms (Signal
sSignal -> [Signal] -> [Signal]
forall a. a -> [a] -> [a]
:[Signal]
ss) [Property]
ps
                PropertyDefinition Property
p -> InterfaceName -> [Method] -> [Signal] -> [Property] -> Interface
Interface InterfaceName
n [Method]
ms [Signal]
ss (Property
pProperty -> [Property] -> [Property]
forall a. a -> [a] -> [a]
:[Property]
ps)
        Interface -> ConduitT Event o Maybe Interface
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Interface -> ConduitT Event o Maybe Interface)
-> Interface -> ConduitT Event o Maybe Interface
forall a b. (a -> b) -> a -> b
$ (InterfaceChildren -> Interface -> Interface)
-> Interface -> [InterfaceChildren] -> Interface
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InterfaceChildren -> Interface -> Interface
addElem Interface
base [InterfaceChildren]
elems

parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren)
parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren)
parseMethod = NameMatcher Name
-> AttrParser MemberName
-> (MemberName -> ConduitT Event o Maybe InterfaceChildren)
-> ConduitT Event o Maybe (Maybe InterfaceChildren)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
X.tag' NameMatcher Name
"method" AttrParser MemberName
getName MemberName -> ConduitT Event o Maybe InterfaceChildren
forall (m :: * -> *) o.
MonadThrow m =>
MemberName -> ConduitT Event o m InterfaceChildren
parseArgs
  where
    getName :: AttrParser MemberName
getName = do
        Text
ifName <- Name -> AttrParser Text
X.requireAttr Name
"name"
        String -> AttrParser MemberName
forall (m :: * -> *). MonadThrow m => String -> m MemberName
parseMemberName (Text -> String
T.unpack Text
ifName)
    parseArgs :: MemberName -> ConduitT Event o m InterfaceChildren
parseArgs MemberName
name = do
        [MethodArg]
args <- ConduitT Event o m (Maybe MethodArg)
-> ConduitT Event o m [MethodArg]
forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
X.many (ConduitT Event o m (Maybe MethodArg)
 -> ConduitT Event o m [MethodArg])
-> ConduitT Event o m (Maybe MethodArg)
-> ConduitT Event o m [MethodArg]
forall a b. (a -> b) -> a -> b
$ do
            ConduitT Event o m (Maybe ()) -> ConduitT Event o m ()
forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ (ConduitT Event o m (Maybe ()) -> ConduitT Event o m ())
-> ConduitT Event o m (Maybe ()) -> ConduitT Event o m ()
forall a b. (a -> b) -> a -> b
$ NameMatcher Name -> AttrParser () -> ConduitT Event o m (Maybe ())
forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
            NameMatcher Name
-> AttrParser MethodArg
-> (MethodArg -> ConduitT Event o m MethodArg)
-> ConduitT Event o m (Maybe MethodArg)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
X.tag' NameMatcher Name
"arg" AttrParser MethodArg
getArg MethodArg -> ConduitT Event o m MethodArg
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ConduitT Event o m (Maybe ()) -> ConduitT Event o m ()
forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ (ConduitT Event o m (Maybe ()) -> ConduitT Event o m ())
-> ConduitT Event o m (Maybe ()) -> ConduitT Event o m ()
forall a b. (a -> b) -> a -> b
$ NameMatcher Name -> AttrParser () -> ConduitT Event o m (Maybe ())
forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
        InterfaceChildren -> ConduitT Event o m InterfaceChildren
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterfaceChildren -> ConduitT Event o m InterfaceChildren)
-> InterfaceChildren -> ConduitT Event o m InterfaceChildren
forall a b. (a -> b) -> a -> b
$ Method -> InterfaceChildren
MethodDefinition (Method -> InterfaceChildren) -> Method -> InterfaceChildren
forall a b. (a -> b) -> a -> b
$ MemberName -> [MethodArg] -> Method
Method MemberName
name [MethodArg]
args
    getArg :: AttrParser MethodArg
getArg = do
        Text
name <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> AttrParser (Maybe Text) -> AttrParser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AttrParser (Maybe Text)
X.attr Name
"name"
        Text
typeStr <- Name -> AttrParser Text
X.requireAttr Name
"type"
        Text
dirStr <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"in" (Maybe Text -> Text) -> AttrParser (Maybe Text) -> AttrParser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AttrParser (Maybe Text)
X.attr Name
"direction"
        AttrParser ()
X.ignoreAttrs
        Type
typ <- Text -> AttrParser Type
forall (m :: * -> *). MonadThrow m => Text -> m Type
parseType Text
typeStr
        let dir :: Direction
dir = if Text
dirStr Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"in" then Direction
In else Direction
Out
        MethodArg -> AttrParser MethodArg
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MethodArg -> AttrParser MethodArg)
-> MethodArg -> AttrParser MethodArg
forall a b. (a -> b) -> a -> b
$ String -> Type -> Direction -> MethodArg
MethodArg (Text -> String
T.unpack Text
name) Type
typ Direction
dir

parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren)
parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren)
parseSignal = NameMatcher Name
-> AttrParser MemberName
-> (MemberName -> ConduitT Event o Maybe InterfaceChildren)
-> ConduitT Event o Maybe (Maybe InterfaceChildren)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
X.tag' NameMatcher Name
"signal" AttrParser MemberName
getName MemberName -> ConduitT Event o Maybe InterfaceChildren
forall (m :: * -> *) o.
MonadThrow m =>
MemberName -> ConduitT Event o m InterfaceChildren
parseArgs
  where
    getName :: AttrParser MemberName
getName = do
        Text
ifName <- Name -> AttrParser Text
X.requireAttr Name
"name"
        String -> AttrParser MemberName
forall (m :: * -> *). MonadThrow m => String -> m MemberName
parseMemberName (Text -> String
T.unpack Text
ifName)
    parseArgs :: MemberName -> ConduitT Event o m InterfaceChildren
parseArgs MemberName
name = do
        [SignalArg]
args <- ConduitT Event o m (Maybe SignalArg)
-> ConduitT Event o m [SignalArg]
forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
X.many (ConduitT Event o m (Maybe SignalArg)
 -> ConduitT Event o m [SignalArg])
-> ConduitT Event o m (Maybe SignalArg)
-> ConduitT Event o m [SignalArg]
forall a b. (a -> b) -> a -> b
$ do
            ConduitT Event o m (Maybe ()) -> ConduitT Event o m ()
forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ (ConduitT Event o m (Maybe ()) -> ConduitT Event o m ())
-> ConduitT Event o m (Maybe ()) -> ConduitT Event o m ()
forall a b. (a -> b) -> a -> b
$ NameMatcher Name -> AttrParser () -> ConduitT Event o m (Maybe ())
forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
            NameMatcher Name
-> AttrParser SignalArg
-> (SignalArg -> ConduitT Event o m SignalArg)
-> ConduitT Event o m (Maybe SignalArg)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
X.tag' NameMatcher Name
"arg" AttrParser SignalArg
getArg SignalArg -> ConduitT Event o m SignalArg
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ConduitT Event o m (Maybe ()) -> ConduitT Event o m ()
forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ (ConduitT Event o m (Maybe ()) -> ConduitT Event o m ())
-> ConduitT Event o m (Maybe ()) -> ConduitT Event o m ()
forall a b. (a -> b) -> a -> b
$ NameMatcher Name -> AttrParser () -> ConduitT Event o m (Maybe ())
forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
        InterfaceChildren -> ConduitT Event o m InterfaceChildren
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterfaceChildren -> ConduitT Event o m InterfaceChildren)
-> InterfaceChildren -> ConduitT Event o m InterfaceChildren
forall a b. (a -> b) -> a -> b
$ Signal -> InterfaceChildren
SignalDefinition (Signal -> InterfaceChildren) -> Signal -> InterfaceChildren
forall a b. (a -> b) -> a -> b
$ MemberName -> [SignalArg] -> Signal
Signal MemberName
name [SignalArg]
args
    getArg :: AttrParser SignalArg
getArg = do
        Text
name <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> AttrParser (Maybe Text) -> AttrParser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AttrParser (Maybe Text)
X.attr Name
"name"
        Text
typeStr <- Name -> AttrParser Text
X.requireAttr Name
"type"
        AttrParser ()
X.ignoreAttrs
        Type
typ <- Text -> AttrParser Type
forall (m :: * -> *). MonadThrow m => Text -> m Type
parseType Text
typeStr
        SignalArg -> AttrParser SignalArg
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignalArg -> AttrParser SignalArg)
-> SignalArg -> AttrParser SignalArg
forall a b. (a -> b) -> a -> b
$ String -> Type -> SignalArg
SignalArg (Text -> String
T.unpack Text
name) Type
typ

parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren)
parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren)
parseProperty = NameMatcher Name
-> AttrParser InterfaceChildren
-> (InterfaceChildren -> ConduitT Event o Maybe InterfaceChildren)
-> ConduitT Event o Maybe (Maybe InterfaceChildren)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
X.tag' NameMatcher Name
"property" AttrParser InterfaceChildren
getProp ((InterfaceChildren -> ConduitT Event o Maybe InterfaceChildren)
 -> ConduitT Event o Maybe (Maybe InterfaceChildren))
-> (InterfaceChildren -> ConduitT Event o Maybe InterfaceChildren)
-> ConduitT Event o Maybe (Maybe InterfaceChildren)
forall a b. (a -> b) -> a -> b
$ \InterfaceChildren
p -> do
    ConduitT Event o Maybe (Maybe ()) -> ConduitT Event o Maybe ()
forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ ConduitT Event o Maybe (Maybe ())
forall (m :: * -> *) o.
MonadThrow m =>
ConduitT Event o m (Maybe ())
X.ignoreAnyTreeContent
    InterfaceChildren -> ConduitT Event o Maybe InterfaceChildren
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterfaceChildren
p
  where
    getProp :: AttrParser InterfaceChildren
getProp = do
        String
name <- Text -> String
T.unpack (Text -> String) -> AttrParser Text -> AttrParser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AttrParser Text
X.requireAttr Name
"name"
        Text
typeStr <- Name -> AttrParser Text
X.requireAttr Name
"type"
        Text
accessStr <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> AttrParser (Maybe Text) -> AttrParser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AttrParser (Maybe Text)
X.attr Name
"access"
        AttrParser ()
X.ignoreAttrs
        Type
typ <- Text -> AttrParser Type
forall (m :: * -> *). MonadThrow m => Text -> m Type
parseType Text
typeStr
        (Bool
canRead, Bool
canWrite) <- case Text
accessStr of
            Text
""          -> (Bool, Bool) -> AttrParser (Bool, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Bool
False)
            Text
"read"      -> (Bool, Bool) -> AttrParser (Bool, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, Bool
False)
            Text
"write"     -> (Bool, Bool) -> AttrParser (Bool, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Bool
True)
            Text
"readwrite" -> (Bool, Bool) -> AttrParser (Bool, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, Bool
True)
            Text
_           -> IOError -> AttrParser (Bool, Bool)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (IOError -> AttrParser (Bool, Bool))
-> IOError -> AttrParser (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"invalid access value"

        InterfaceChildren -> AttrParser InterfaceChildren
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterfaceChildren -> AttrParser InterfaceChildren)
-> InterfaceChildren -> AttrParser InterfaceChildren
forall a b. (a -> b) -> a -> b
$ Property -> InterfaceChildren
PropertyDefinition (Property -> InterfaceChildren) -> Property -> InterfaceChildren
forall a b. (a -> b) -> a -> b
$ String -> Type -> Bool -> Bool -> Property
Property String
name Type
typ Bool
canRead Bool
canWrite

parseType :: MonadThrow m => T.Text -> m Type
parseType :: Text -> m Type
parseType Text
typeStr = do
    Signature
typ <- String -> m Signature
forall (m :: * -> *). MonadThrow m => String -> m Signature
parseSignature (Text -> String
T.unpack Text
typeStr)
    case Signature -> [Type]
signatureTypes Signature
typ of
        [Type
t] -> Type -> m Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
        [Type]
_ -> IOError -> m Type
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (IOError -> m Type) -> IOError -> m Type
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"invalid type sig"