#line 44 "src/introspection.anansi"

#line 30 "src/introduction.anansi"
-- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

#line 45 "src/introspection.anansi"

#line 52 "src/introduction.anansi"
{-# LANGUAGE OverloadedStrings #-}

#line 46 "src/introspection.anansi"
module DBus.Introspection
	( Object (..)
	, Interface (..)
	, Method (..)
	, Signal (..)
	, Parameter (..)
	, Property (..)
	, PropertyAccess (..)
	, toXML
	, fromXML
	) where

#line 56 "src/introduction.anansi"
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL

#line 58 "src/introspection.anansi"

#line 66 "src/introspection.anansi"
import qualified Text.XML.HaXml as H

#line 105 "src/introspection.anansi"
import Text.XML.HaXml.Parse (xmlParse')
import DBus.Util (eitherToMaybe)

#line 230 "src/introspection.anansi"
import Data.Char (chr)

#line 254 "src/introspection.anansi"
import Data.Maybe (fromMaybe)

#line 286 "src/introspection.anansi"
import Text.XML.HaXml.Pretty (document)
import Text.PrettyPrint.HughesPJ (render)

#line 59 "src/introspection.anansi"
import qualified DBus.Types as T

#line 72 "src/introspection.anansi"
data Object = Object T.ObjectPath [Interface] [Object]
	deriving (Show, Eq)

data Interface = Interface T.InterfaceName [Method] [Signal] [Property]
	deriving (Show, Eq)

data Method = Method T.MemberName [Parameter] [Parameter]
	deriving (Show, Eq)

data Signal = Signal T.MemberName [Parameter]
	deriving (Show, Eq)

data Parameter = Parameter Text T.Signature
	deriving (Show, Eq)

data Property = Property Text T.Signature [PropertyAccess]
	deriving (Show, Eq)

data PropertyAccess = Read | Write
	deriving (Show, Eq)

#line 110 "src/introspection.anansi"
fromXML :: T.ObjectPath -> Text -> Maybe Object
fromXML path text = do
	doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text
	let (H.Document _ _ root _) = doc
	parseRoot path root

#line 121 "src/introspection.anansi"
parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object
parseRoot defaultPath e = do
	path <- case getAttr "name" e of
		Nothing -> Just defaultPath
		Just x  -> T.mkObjectPath x
	parseObject' path e

#line 134 "src/introspection.anansi"
parseChild :: T.ObjectPath -> H.Element a -> Maybe Object
parseChild parentPath e = do
	let parentPath' = case T.strObjectPath parentPath of
		"/" -> "/"
		x   -> TL.append x "/"
	pathSegment <- getAttr "name" e
	path <- T.mkObjectPath $ TL.append parentPath' pathSegment
	parseObject' path e

#line 148 "src/introspection.anansi"
parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object
parseObject' path e@(H.Elem "node" _ _)  = do
	interfaces <- children parseInterface (H.tag "interface") e
	children' <- children (parseChild path) (H.tag "node") e
	return $ Object path interfaces children'
parseObject' _ _ = Nothing

#line 159 "src/introspection.anansi"
parseInterface :: H.Element a -> Maybe Interface
parseInterface e = do
	name <- T.mkInterfaceName =<< getAttr "name" e
	methods <- children parseMethod (H.tag "method") e
	signals <- children parseSignal (H.tag "signal") e
	properties <- children parseProperty (H.tag "property") e
	return $ Interface name methods signals properties

#line 172 "src/introspection.anansi"
parseMethod :: H.Element a -> Maybe Method
parseMethod e = do
	name <- T.mkMemberName =<< getAttr "name" e
	paramsIn <- children parseParameter (isParam ["in", ""]) e
	paramsOut <- children parseParameter (isParam ["out"]) e
	return $ Method name paramsIn paramsOut

#line 183 "src/introspection.anansi"
parseSignal :: H.Element a -> Maybe Signal
parseSignal e = do
	name <- T.mkMemberName =<< getAttr "name" e
	params <- children parseParameter (isParam ["out", ""]) e
	return $ Signal name params

#line 193 "src/introspection.anansi"
parseParameter :: H.Element a -> Maybe Parameter
parseParameter e = do
	let name = getAttr' "name" e
	sig <- parseType e
	return $ Parameter name sig

#line 201 "src/introspection.anansi"
parseType :: H.Element a -> Maybe T.Signature
parseType e = do
	sig <- T.mkSignature =<< getAttr "type" e
	case T.signatureTypes sig of
		[_] -> Just sig
		_   -> Nothing

#line 213 "src/introspection.anansi"
parseProperty :: H.Element a -> Maybe Property
parseProperty e = do
	let name = getAttr' "name" e
	sig <- parseType e
	access <- case getAttr' "access" e of
		""          -> Just []
		"read"      -> Just [Read]
		"write"     -> Just [Write]
		"readwrite" -> Just [Read, Write]
		_           -> Nothing
	return $ Property name sig access

#line 234 "src/introspection.anansi"
attrValue :: H.AttValue -> Maybe Text
attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where
	(H.AttValue parts) = attr
	
	unescape (Left x) = Just x
	unescape (Right (H.RefEntity x)) = lookup x namedRefs
	unescape (Right (H.RefChar x)) = Just [chr x]
	
	namedRefs =
		[ ("lt", "<")
		, ("gt", ">")
		, ("amp", "&")
		, ("apos", "'")
		, ("quot", "\"")
		]

#line 258 "src/introspection.anansi"
getAttr :: String -> H.Element a -> Maybe Text
getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue

getAttr' :: String -> H.Element a -> Text
getAttr' = (fromMaybe "" .) . getAttr

isParam :: [Text] -> H.CFilter a
isParam dirs content = do
	arg@(H.CElem e _) <- H.tag "arg" content
	let direction = getAttr' "direction" e
	[arg | direction `elem` dirs]

children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]
children f filt (H.Elem _ _ contents) =
	mapM f [x | (H.CElem x _) <- concatMap filt contents]

#line 278 "src/introspection.anansi"
dtdPublicID, dtdSystemID :: String
dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"

#line 294 "src/introspection.anansi"
toXML :: Object -> Maybe Text
toXML obj = fmap (TL.pack . render . document) doc where
	prolog = H.Prolog Nothing [] (Just doctype) []
	doctype = H.DTD "node" (Just (H.PUBLIC
		(H.PubidLiteral dtdPublicID)
		(H.SystemLiteral dtdSystemID))) []
	doc = do
		root <- xmlRoot obj
		return $ H.Document prolog H.emptyST root []

#line 309 "src/introspection.anansi"
xmlRoot :: Object -> Maybe (H.Element a)
xmlRoot obj@(Object path _ _) = do
	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj
	return root

#line 316 "src/introspection.anansi"
xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a)
xmlObject parentPath obj@(Object path _ _) = do
	let path' = T.strObjectPath path
	    parent' = T.strObjectPath parentPath
	relpath <- if TL.isPrefixOf parent' path'
		then Just $ if parent' == "/"
			then TL.drop 1 path'
			else TL.drop (TL.length parent' + 1) path'
		else Nothing
	xmlObject' relpath obj

#line 329 "src/introspection.anansi"
xmlObject' :: Text -> Object -> Maybe (H.Content a)
xmlObject' path (Object fullPath interfaces children') = do
	children'' <- mapM (xmlObject fullPath) children'
	return $ mkElement "node"
		[mkAttr "name" $ TL.unpack path]
		$ concat
			[ map xmlInterface interfaces
			, children''
			]

#line 341 "src/introspection.anansi"
xmlInterface :: Interface -> H.Content a
xmlInterface (Interface name methods signals properties) =
	mkElement "interface"
		[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]
		$ concat
			[ map xmlMethod methods
			, map xmlSignal signals
			, map xmlProperty properties
			]

#line 353 "src/introspection.anansi"
xmlMethod :: Method -> H.Content a
xmlMethod (Method name inParams outParams) = mkElement "method"
	[mkAttr "name" . TL.unpack . T.strMemberName $ name]
	$ concat
		[ map (xmlParameter "in") inParams
		, map (xmlParameter "out") outParams
		]

#line 363 "src/introspection.anansi"
xmlSignal :: Signal -> H.Content a
xmlSignal (Signal name params) = mkElement "signal"
	[mkAttr "name" . TL.unpack . T.strMemberName $ name]
	$ map (xmlParameter "out") params

#line 370 "src/introspection.anansi"
xmlParameter :: String -> Parameter -> H.Content a
xmlParameter direction (Parameter name sig) = mkElement "arg"
	[ mkAttr "name" . TL.unpack $ name
	, mkAttr "type" . TL.unpack . T.strSignature $ sig
	, mkAttr "direction" direction
	] []

#line 379 "src/introspection.anansi"
xmlProperty :: Property -> H.Content a
xmlProperty (Property name sig access) = mkElement "property"
	[ mkAttr "name" . TL.unpack $ name
	, mkAttr "type" . TL.unpack . T.strSignature $ sig
	, mkAttr "access" $ xmlAccess access
	] []

#line 388 "src/introspection.anansi"
xmlAccess :: [PropertyAccess] -> String
xmlAccess access = readS ++ writeS where
	readS = if elem Read access then "read" else ""
	writeS = if elem Write access then "write" else ""

#line 395 "src/introspection.anansi"
mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a
mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined

mkAttr :: String -> String -> H.Attribute
mkAttr name value = (name, H.AttValue [Left escaped]) where
	raw = H.CString True value ()
	escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]