{-# 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 =
    forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [Text
xml] forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT Text Event m ()
X.parseText forall a. Default a => a
X.def forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a.
MonadThrow m =>
String -> m (Maybe a) -> m a
X.force String
"parse error" (forall o.
AttrParser ObjectPath -> ConduitT Event o Maybe (Maybe Object)
parseObject 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"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe ObjectPath
defaultPath (String -> ObjectPath
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 forall a. [a] -> [a] -> [a]
++ String
"/"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> ObjectPath
objectPath_ (String
parentPath' forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
nodeName)

parseObject
    :: X.AttrParser ObjectPath
    -> ConduitT Event o Maybe (Maybe Object)
parseObject :: forall o.
AttrParser ObjectPath -> ConduitT Event o Maybe (Maybe Object)
parseObject AttrParser ObjectPath
getPath = 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 forall {o}. ObjectPath -> ConduitT Event o Maybe Object
parseContent
  where
    parseContent :: ObjectPath -> ConduitT Event o Maybe Object
parseContent ObjectPath
objPath = do
        [ObjectChildren]
elems <- forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
X.many forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o a.
Monad m =>
[ConduitT Event o m (Maybe a)] -> ConduitT Event o m (Maybe a)
X.choose
            [ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Object -> ObjectChildren
SubNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall o.
AttrParser ObjectPath -> ConduitT Event o Maybe (Maybe Object)
parseObject (ObjectPath -> AttrParser ObjectPath
getChildName ObjectPath
objPath)
            , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Interface -> ObjectChildren
InterfaceDefinition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
iforall a. a -> [a] -> [a]
:[Interface]
is) [Object]
cs
                SubNode Object
c -> ObjectPath -> [Interface] -> [Object] -> Object
Object ObjectPath
p [Interface]
is (Object
cforall a. a -> [a] -> [a]
:[Object]
cs)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: forall o. ConduitT Event o Maybe (Maybe Interface)
parseInterface = 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 forall {o}. InterfaceName -> ConduitT Event o Maybe Interface
parseContent
  where
    getName :: AttrParser InterfaceName
getName = do
        Text
ifName <- Name -> AttrParser Text
X.requireAttr Name
"name"
        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
X.many forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
            forall (m :: * -> *) o a.
Monad m =>
[ConduitT Event o m (Maybe a)] -> ConduitT Event o m (Maybe a)
X.choose
                [ forall o. ConduitT Event o Maybe (Maybe InterfaceChildren)
parseMethod
                , forall o. ConduitT Event o Maybe (Maybe InterfaceChildren)
parseSignal
                , forall o. ConduitT Event o Maybe (Maybe InterfaceChildren)
parseProperty
                ]
        forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ forall a b. (a -> b) -> a -> b
$ 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
mforall a. a -> [a] -> [a]
:[Method]
ms) [Signal]
ss [Property]
ps
                SignalDefinition Signal
s -> InterfaceName -> [Method] -> [Signal] -> [Property] -> Interface
Interface InterfaceName
n [Method]
ms (Signal
sforall a. a -> [a] -> [a]
:[Signal]
ss) [Property]
ps
                PropertyDefinition Property
p -> InterfaceName -> [Method] -> [Signal] -> [Property] -> Interface
Interface InterfaceName
n [Method]
ms [Signal]
ss (Property
pforall a. a -> [a] -> [a]
:[Property]
ps)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: forall o. ConduitT Event o Maybe (Maybe InterfaceChildren)
parseMethod = 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 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"
        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 <- forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
X.many forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
            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 forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Method -> InterfaceChildren
MethodDefinition forall a b. (a -> b) -> a -> b
$ MemberName -> [MethodArg] -> Method
Method MemberName
name [MethodArg]
args
    getArg :: AttrParser MethodArg
getArg = do
        Text
name <- forall a. a -> Maybe a -> a
fromMaybe 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 <- forall a. a -> Maybe a -> a
fromMaybe Text
"in" 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 <- forall (m :: * -> *). MonadThrow m => Text -> m Type
parseType Text
typeStr
        let dir :: Direction
dir = if Text
dirStr forall a. Eq a => a -> a -> Bool
== Text
"in" then Direction
In else Direction
Out
        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall o. ConduitT Event o Maybe (Maybe InterfaceChildren)
parseSignal = 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 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"
        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 <- forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
X.many forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
            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 forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b o.
MonadThrow m =>
NameMatcher a -> AttrParser b -> ConduitT Event o m (Maybe ())
X.ignoreTreeContent NameMatcher Name
"annotation" AttrParser ()
X.ignoreAttrs
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Signal -> InterfaceChildren
SignalDefinition forall a b. (a -> b) -> a -> b
$ MemberName -> [SignalArg] -> Signal
Signal MemberName
name [SignalArg]
args
    getArg :: AttrParser SignalArg
getArg = do
        Text
name <- forall a. a -> Maybe a -> a
fromMaybe 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 <- forall (m :: * -> *). MonadThrow m => Text -> m Type
parseType Text
typeStr
        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall o. ConduitT Event o Maybe (Maybe InterfaceChildren)
parseProperty = 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 forall a b. (a -> b) -> a -> b
$ \InterfaceChildren
p -> do
    forall (m :: * -> *) o a.
MonadThrow m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m ()
X.many_ forall (m :: * -> *) o.
MonadThrow m =>
ConduitT Event o m (Maybe ())
X.ignoreAnyTreeContent
    forall (f :: * -> *) a. Applicative f => a -> f a
pure InterfaceChildren
p
  where
    getProp :: AttrParser InterfaceChildren
getProp = do
        String
name <- Text -> String
T.unpack 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 <- forall a. a -> Maybe a -> a
fromMaybe 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 <- forall (m :: * -> *). MonadThrow m => Text -> m Type
parseType Text
typeStr
        (Bool
canRead, Bool
canWrite) <- case Text
accessStr of
            Text
""          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Bool
False)
            Text
"read"      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, Bool
False)
            Text
"write"     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Bool
True)
            Text
"readwrite" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, Bool
True)
            Text
_           -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"invalid access value"

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