#line 22 "src/types.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 23 "src/types.anansi"

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

#line 24 "src/types.anansi"

#line 358 "src/types.anansi"
{-# LANGUAGE TypeSynonymInstances #-}

#line 25 "src/types.anansi"
module DBus.Types (

#line 89 "src/types.anansi"
	  -- * Available types
	  Type (..)
	, typeCode

#line 165 "src/types.anansi"
	  -- * Variants
	, Variant
	, Variable (..)

#line 234 "src/types.anansi"
	, variantType

#line 425 "src/types.anansi"
	  -- * Signatures
	, Signature
	, signatureTypes
	, strSignature

#line 601 "src/types.anansi"
	, mkSignature
	, mkSignature_

#line 658 "src/types.anansi"
	  -- * Object paths
	, ObjectPath
	, strObjectPath
	, mkObjectPath
	, mkObjectPath_

#line 713 "src/types.anansi"
	  -- * Arrays
	, Array
	, arrayType
	, arrayItems

#line 759 "src/types.anansi"
	, toArray
	, fromArray
	, arrayFromItems

#line 777 "src/types.anansi"
	, arrayToBytes
	, arrayFromBytes

#line 846 "src/types.anansi"
	  -- * Dictionaries
	, Dictionary
	, dictionaryItems
	, dictionaryKeyType
	, dictionaryValueType

#line 923 "src/types.anansi"
	, toDictionary
	, fromDictionary
	, dictionaryFromItems

#line 995 "src/types.anansi"
	, dictionaryToArray
	, arrayToDictionary

#line 1011 "src/types.anansi"
	  -- * Structures
	, Structure (..)

#line 1052 "src/types.anansi"
	-- * Names

#line 1082 "src/types.anansi"
	  -- ** Bus names
	, BusName
	, strBusName
	, mkBusName
	, mkBusName_

#line 1135 "src/types.anansi"
	  -- ** Interface names
	, InterfaceName
	, strInterfaceName
	, mkInterfaceName
	, mkInterfaceName_

#line 1176 "src/types.anansi"
	  -- ** Error names
	, ErrorName
	, strErrorName
	, mkErrorName
	, mkErrorName_

#line 1212 "src/types.anansi"
	  -- ** Member names
	, MemberName
	, strMemberName
	, mkMemberName
	, mkMemberName_

#line 27 "src/types.anansi"
	) where

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

#line 29 "src/types.anansi"

#line 311 "src/types.anansi"
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)

#line 345 "src/types.anansi"
import qualified Data.Text as T

#line 416 "src/types.anansi"
import Data.Ord (comparing)

#line 517 "src/types.anansi"
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import DBus.Util (checkLength, parseMaybe)

#line 584 "src/types.anansi"
import DBus.Util (mkUnsafe)
import qualified Data.String as String

#line 691 "src/types.anansi"
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString

#line 791 "src/types.anansi"
import qualified Data.ByteString as StrictByteString

#line 857 "src/types.anansi"
import Data.List (intercalate)

#line 874 "src/types.anansi"
import Control.Monad (unless)

#line 896 "src/types.anansi"
import Control.Arrow ((***))
import qualified Data.Map as Map

#line 908 "src/types.anansi"
import Control.Monad (forM)

#line 41 "src/types.anansi"
data Type
	= DBusBoolean
	| DBusByte
	| DBusInt16
	| DBusInt32
	| DBusInt64
	| DBusWord16
	| DBusWord32
	| DBusWord64
	| DBusDouble
	| DBusString
	| DBusSignature
	| DBusObjectPath
	| DBusVariant
	| DBusArray Type
	| DBusDictionary Type Type
	| DBusStructure [Type]
	deriving (Show, Eq)

#line 62 "src/types.anansi"

#line 27 "src/api-docs.anansi"
-- | \"Atomic\" types are any which can't contain any other types. Only
-- atomic types may be used as dictionary keys.

#line 63 "src/types.anansi"
isAtomicType :: Type -> Bool
isAtomicType DBusBoolean    = True
isAtomicType DBusByte       = True
isAtomicType DBusInt16      = True
isAtomicType DBusInt32      = True
isAtomicType DBusInt64      = True
isAtomicType DBusWord16     = True
isAtomicType DBusWord32     = True
isAtomicType DBusWord64     = True
isAtomicType DBusDouble     = True
isAtomicType DBusString     = True
isAtomicType DBusSignature  = True
isAtomicType DBusObjectPath = True
isAtomicType _              = False

#line 83 "src/types.anansi"

#line 32 "src/api-docs.anansi"
-- | Every type has an associated type code; a textual representation of
-- the type, useful for debugging.

#line 84 "src/types.anansi"
typeCode :: Type -> Text

#line 437 "src/types.anansi"
typeCode DBusBoolean    = "b"
typeCode DBusByte       = "y"
typeCode DBusInt16      = "n"
typeCode DBusInt32      = "i"
typeCode DBusInt64      = "x"
typeCode DBusWord16     = "q"
typeCode DBusWord32     = "u"
typeCode DBusWord64     = "t"
typeCode DBusDouble     = "d"
typeCode DBusString     = "s"
typeCode DBusSignature  = "g"
typeCode DBusObjectPath = "o"
typeCode DBusVariant    = "v"

#line 456 "src/types.anansi"
typeCode (DBusArray t) = TL.cons 'a' $ typeCode t

#line 463 "src/types.anansi"
typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]

#line 471 "src/types.anansi"
typeCode (DBusStructure ts) = TL.concat $
	["("] ++ map typeCode ts ++ [")"]

#line 139 "src/types.anansi"

#line 37 "src/api-docs.anansi"
-- | 'Variant's may contain any other built-in D-Bus value. Besides
-- representing native @VARIANT@ values, they allow type-safe storage and
-- deconstruction of heterogeneous collections.

#line 140 "src/types.anansi"
data Variant
	= VarBoxBool Bool
	| VarBoxWord8 Word8
	| VarBoxInt16 Int16
	| VarBoxInt32 Int32
	| VarBoxInt64 Int64
	| VarBoxWord16 Word16
	| VarBoxWord32 Word32
	| VarBoxWord64 Word64
	| VarBoxDouble Double
	| VarBoxString Text
	| VarBoxSignature Signature
	| VarBoxObjectPath ObjectPath
	| VarBoxVariant Variant
	| VarBoxArray Array
	| VarBoxDictionary Dictionary
	| VarBoxStructure Structure
	deriving (Eq)

class Variable a where
	toVariant :: a -> Variant
	fromVariant :: Variant -> Maybe a

#line 175 "src/types.anansi"
instance Show Variant where
	showsPrec d var = showParen (d > 10) full where
		full = s "Variant " . shows code . s " " . valueStr
		code = typeCode $ variantType var
		s = showString
		valueStr = showsPrecVar 11 var

showsPrecVar :: Int -> Variant -> ShowS
showsPrecVar d var = case var of
	(VarBoxBool x) -> showsPrec d x
	(VarBoxWord8 x) -> showsPrec d x
	(VarBoxInt16 x) -> showsPrec d x
	(VarBoxInt32 x) -> showsPrec d x
	(VarBoxInt64 x) -> showsPrec d x
	(VarBoxWord16 x) -> showsPrec d x
	(VarBoxWord32 x) -> showsPrec d x
	(VarBoxWord64 x) -> showsPrec d x
	(VarBoxDouble x) -> showsPrec d x
	(VarBoxString x) -> showsPrec d x
	(VarBoxSignature x) -> showsPrec d x
	(VarBoxObjectPath x) -> showsPrec d x
	(VarBoxVariant x) -> showsPrec d x
	(VarBoxArray x) -> showsPrec d x
	(VarBoxDictionary x) -> showsPrec d x
	(VarBoxStructure x) -> showsPrec d x

#line 207 "src/types.anansi"

#line 43 "src/api-docs.anansi"
-- | Every variant is strongly-typed; that is, the type of its contained
-- value is known at all times. This function retrieves that type, so that
-- the correct cast can be used to retrieve the value.

#line 208 "src/types.anansi"
variantType :: Variant -> Type
variantType var = case var of
	(VarBoxBool _) -> DBusBoolean
	(VarBoxWord8 _) -> DBusByte
	(VarBoxInt16 _) -> DBusInt16
	(VarBoxInt32 _) -> DBusInt32
	(VarBoxInt64 _) -> DBusInt64
	(VarBoxWord16 _) -> DBusWord16
	(VarBoxWord32 _) -> DBusWord32
	(VarBoxWord64 _) -> DBusWord64
	(VarBoxDouble _) -> DBusDouble
	(VarBoxString _) -> DBusString
	(VarBoxSignature _) -> DBusSignature
	(VarBoxObjectPath _) -> DBusObjectPath
	(VarBoxVariant _) -> DBusVariant
	(VarBoxArray x) -> DBusArray (arrayType x)
	(VarBoxDictionary x) -> let
		keyT = dictionaryKeyType x
		valueT = dictionaryValueType x
		in DBusDictionary keyT valueT
	(VarBoxStructure x) -> let
		Structure items = x
		in DBusStructure (map variantType items)

#line 241 "src/types.anansi"
#define INSTANCE_VARIABLE(TYPE) \
	instance Variable TYPE where \
		{ toVariant = VarBox/**/TYPE \
		; fromVariant (VarBox/**/TYPE x) = Just x \
		; fromVariant _ = Nothing \
		}

#line 252 "src/types.anansi"
INSTANCE_VARIABLE(Variant)

#line 316 "src/types.anansi"
INSTANCE_VARIABLE(Bool)
INSTANCE_VARIABLE(Word8)
INSTANCE_VARIABLE(Int16)
INSTANCE_VARIABLE(Int32)
INSTANCE_VARIABLE(Int64)
INSTANCE_VARIABLE(Word16)
INSTANCE_VARIABLE(Word32)
INSTANCE_VARIABLE(Word64)
INSTANCE_VARIABLE(Double)

#line 334 "src/types.anansi"
instance Variable TL.Text where
	toVariant = VarBoxString
	fromVariant (VarBoxString x) = Just x
	fromVariant _ = Nothing

#line 349 "src/types.anansi"
instance Variable T.Text where
	toVariant = toVariant . TL.fromChunks . (:[])
	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant

#line 362 "src/types.anansi"
instance Variable String where
	toVariant = toVariant . TL.pack
	fromVariant = fmap TL.unpack . fromVariant

#line 395 "src/types.anansi"
INSTANCE_VARIABLE(Signature)
data Signature = Signature { signatureTypes :: [Type] }
	deriving (Eq)

instance Show Signature where
	showsPrec d x = showParen (d > 10) $
		showString "Signature " . shows (strSignature x)

#line 408 "src/types.anansi"
strSignature :: Signature -> Text
strSignature (Signature ts) = TL.concat $ map typeCode ts

#line 420 "src/types.anansi"
instance Ord Signature where
	compare = comparing strSignature

#line 482 "src/types.anansi"
mkSignature :: Text -> Maybe Signature
mkSignature text = parsed where

#line 496 "src/types.anansi"
	just t = Just $ Signature [t]
	fast = case TL.head text of
		'b' -> just DBusBoolean
		'y' -> just DBusByte
		'n' -> just DBusInt16
		'i' -> just DBusInt32
		'x' -> just DBusInt64
		'q' -> just DBusWord16
		'u' -> just DBusWord32
		't' -> just DBusWord64
		'd' -> just DBusDouble
		's' -> just DBusString
		'g' -> just DBusSignature
		'o' -> just DBusObjectPath
		'v' -> just DBusVariant
		_   -> Nothing

#line 485 "src/types.anansi"

#line 523 "src/types.anansi"
	slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text
	sigParser = do
		types <- P.many parseType
		P.eof
		return $ Signature types

#line 534 "src/types.anansi"
	parseType = parseAtom <|> parseContainer
	parseContainer =
		    parseArray
		<|> parseStruct
		<|> (P.char 'v' >> return DBusVariant)

#line 542 "src/types.anansi"
	parseArray = do
		P.char 'a'
		parseDict <|> fmap DBusArray parseType
	parseDict = do
		P.char '{'
		keyType <- parseAtom
		valueType <- parseType
		P.char '}'
		return $ DBusDictionary keyType valueType

#line 556 "src/types.anansi"
	parseStruct = do
		P.char '('
		types <- P.many parseType
		P.char ')'
		return $ DBusStructure types

#line 564 "src/types.anansi"
	parseAtom =
		    (P.char 'b' >> return DBusBoolean)
		<|> (P.char 'y' >> return DBusByte)
		<|> (P.char 'n' >> return DBusInt16)
		<|> (P.char 'i' >> return DBusInt32)
		<|> (P.char 'x' >> return DBusInt64)
		<|> (P.char 'q' >> return DBusWord16)
		<|> (P.char 'u' >> return DBusWord32)
		<|> (P.char 't' >> return DBusWord64)
		<|> (P.char 'd' >> return DBusDouble)
		<|> (P.char 's' >> return DBusString)
		<|> (P.char 'g' >> return DBusSignature)
		<|> (P.char 'o' >> return DBusObjectPath)

#line 486 "src/types.anansi"
	parsed = case TL.length text of
		0 -> Just $ Signature []
		1 -> fast
		_ -> slow

#line 589 "src/types.anansi"
mkSignature_ :: Text -> Signature
mkSignature_ = mkUnsafe "signature" mkSignature

instance String.IsString Signature where
	fromString = mkSignature_ . TL.pack

#line 620 "src/types.anansi"
INSTANCE_VARIABLE(ObjectPath)
newtype ObjectPath = ObjectPath
	{ strObjectPath :: Text
	}
	deriving (Eq, Ord)

instance Show ObjectPath where
	showsPrec d (ObjectPath x) = showParen (d > 10) $
		showString "ObjectPath " . shows x

instance String.IsString ObjectPath where
	fromString = mkObjectPath_ . TL.pack

#line 647 "src/types.anansi"
mkObjectPath :: Text -> Maybe ObjectPath
mkObjectPath s = parseMaybe path' (TL.unpack s) where
	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"
	path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char
	path' = path >> P.eof >> return (ObjectPath s)

mkObjectPath_ :: Text -> ObjectPath
mkObjectPath_ = mkUnsafe "object path" mkObjectPath

#line 696 "src/types.anansi"
INSTANCE_VARIABLE(Array)
data Array
	= VariantArray Type [Variant]
	| ByteArray ByteString
	deriving (Eq)


#line 49 "src/api-docs.anansi"
-- | This is the type contained within the array, not the type of the array
-- itself.

#line 703 "src/types.anansi"
arrayType :: Array -> Type
arrayType (VariantArray t _) = t
arrayType (ByteArray _) = DBusByte

arrayItems :: Array -> [Variant]
arrayItems (VariantArray _ xs) = xs
arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs

#line 723 "src/types.anansi"
instance Show Array where
	showsPrec d array = showParen (d > 10) $
		s "Array " . showSig . s " [" . s valueString . s "]" where
			s = showString
			showSig = shows . typeCode . arrayType $ array
			showVar var = showsPrecVar 0 var ""
			valueString = intercalate ", " $ map showVar $ arrayItems array

#line 737 "src/types.anansi"
arrayFromItems :: Type -> [Variant] -> Maybe Array
arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)

arrayFromItems t vs = do
	mkSignature (typeCode t)
	if all (\x -> variantType x == t) vs
		then Just $ VariantArray t vs
		else Nothing

#line 751 "src/types.anansi"
toArray :: Variable a => Type -> [a] -> Maybe Array
toArray t = arrayFromItems t . map toVariant

fromArray :: Variable a => Array -> Maybe [a]
fromArray = mapM fromVariant . arrayItems

#line 768 "src/types.anansi"
arrayToBytes :: Array -> Maybe ByteString
arrayToBytes (ByteArray x) = Just x
arrayToBytes _             = Nothing

arrayFromBytes :: ByteString -> Array
arrayFromBytes = ByteArray

#line 785 "src/types.anansi"
instance Variable ByteString where
	toVariant = toVariant . arrayFromBytes
	fromVariant x = fromVariant x >>= arrayToBytes

#line 795 "src/types.anansi"
instance Variable StrictByteString.ByteString where
	toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x]
	fromVariant x = do
		chunks <- ByteString.toChunks `fmap` fromVariant x
		return $ StrictByteString.concat chunks

#line 836 "src/types.anansi"
INSTANCE_VARIABLE(Dictionary)
data Dictionary = Dictionary
	{ dictionaryKeyType   :: Type
	, dictionaryValueType :: Type
	, dictionaryItems     :: [(Variant, Variant)]
	}
	deriving (Eq)

#line 861 "src/types.anansi"
instance Show Dictionary where
	showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $
		s "Dictionary " . showSig . s " {" . s valueString . s "}" where
			s = showString
			showSig = shows $ TL.append (typeCode kt) (typeCode vt)
			valueString = intercalate ", " $ map showPair pairs
			showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) ""

#line 878 "src/types.anansi"
dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary
dictionaryFromItems kt vt pairs = do
	unless (isAtomicType kt) Nothing
	mkSignature (typeCode kt)
	mkSignature (typeCode vt)
	
	let sameType (k, v) = variantType k == kt &&
	                      variantType v == vt
	if all sameType pairs
		then Just $ Dictionary kt vt pairs
		else Nothing

#line 901 "src/types.anansi"
toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b
             -> Maybe Dictionary
toDictionary kt vt = dictionaryFromItems kt vt . pairs where
	pairs = map (toVariant *** toVariant) . Map.toList

#line 912 "src/types.anansi"
fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary
               -> Maybe (Map.Map a b)
fromDictionary (Dictionary _ _ vs) = do
	pairs <- forM vs $ \(k, v) -> do
		k' <- fromVariant k
		v' <- fromVariant v
		return (k', v')
	return $ Map.fromList pairs

#line 972 "src/types.anansi"
dictionaryToArray :: Dictionary -> Array
dictionaryToArray (Dictionary kt vt items) = array where
	Just array = toArray itemType structs
	itemType = DBusStructure [kt, vt]
	structs = [Structure [k, v] | (k, v) <- items]

#line 980 "src/types.anansi"
arrayToDictionary :: Array -> Maybe Dictionary
arrayToDictionary array = do
	let toPair x = do
		struct <- fromVariant x
		case struct of
			Structure [k, v] -> Just (k, v)
			_                -> Nothing
	(kt, vt) <- case arrayType array of
		DBusStructure [kt, vt] -> Just (kt, vt)
		_                      -> Nothing
	pairs <- mapM toPair $ arrayItems array
	dictionaryFromItems kt vt pairs

#line 1005 "src/types.anansi"
INSTANCE_VARIABLE(Structure)
data Structure = Structure [Variant]
	deriving (Show, Eq)

#line 1031 "src/types.anansi"
#define NAME_TYPE(TYPE, NAME) \
	newtype TYPE = TYPE {str/**/TYPE :: Text} \
		deriving (Eq, Ord); \
		\
	instance Show TYPE where \
		{ showsPrec d (TYPE x) = showParen (d > 10) $ \
			showString "TYPE " . shows x \
		}; \
		\
	instance String.IsString TYPE where \
		{ fromString = mk/**/TYPE/**/_ . TL.pack }; \
		\
	instance Variable TYPE where \
		{ toVariant = toVariant . str/**/TYPE \
		; fromVariant = (mk/**/TYPE =<<) . fromVariant }; \
		                                                \
	mk/**/TYPE/**/_ :: Text -> TYPE; \
	mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE

#line 1068 "src/types.anansi"
NAME_TYPE(BusName, "bus name")

mkBusName :: Text -> Maybe BusName
mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where
	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"
	c' = c ++ ['0'..'9']
	parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)
	unique = P.char ':' >> elems c'
	wellKnown = elems c
	elems start = elem' start >> P.many1 (P.char '.' >> elem' start)
	elem' start = P.oneOf start >> P.many (P.oneOf c')

#line 1123 "src/types.anansi"
NAME_TYPE(InterfaceName, "interface name")

mkInterfaceName :: Text -> Maybe InterfaceName
mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where
	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
	c' = c ++ ['0'..'9']
	element = P.oneOf c >> P.many (P.oneOf c')
	name = element >> P.many1 (P.char '.' >> element)
	parser = name >> P.eof >> return (InterfaceName s)

#line 1169 "src/types.anansi"
NAME_TYPE(ErrorName, "error name")

mkErrorName :: Text -> Maybe ErrorName
mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName

#line 1201 "src/types.anansi"
NAME_TYPE(MemberName, "member name")

mkMemberName :: Text -> Maybe MemberName
mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where
	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
	c' = c ++ ['0'..'9']
	name = P.oneOf c >> P.many (P.oneOf c')
	parser = name >> P.eof >> return (MemberName s)