-- 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/>.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
module DBus.Types (
	  -- * Available types
	  Type (..)
	, typeCode
	  -- * Variants
	, Variant
	, Variable (..)
	, variantType
	  -- * Signatures
	, Signature
	, signatureTypes
	, strSignature
	, mkSignature
	, mkSignature_
	  -- * Object paths
	, ObjectPath
	, strObjectPath
	, mkObjectPath
	, mkObjectPath_
	  -- * Arrays
	, Array
	, arrayType
	, arrayItems
	, toArray
	, fromArray
	, arrayFromItems
	, arrayToBytes
	, arrayFromBytes
	  -- * Dictionaries
	, Dictionary
	, dictionaryItems
	, dictionaryKeyType
	, dictionaryValueType
	, toDictionary
	, fromDictionary
	, dictionaryFromItems
	, dictionaryToArray
	, arrayToDictionary
	  -- * Structures
	, Structure (..)
	-- * Names
	  -- ** Bus names
	, BusName
	, strBusName
	, mkBusName
	, mkBusName_
	  -- ** Interface names
	, InterfaceName
	, strInterfaceName
	, mkInterfaceName
	, mkInterfaceName_
	  -- ** Error names
	, ErrorName
	, strErrorName
	, mkErrorName
	, mkErrorName_
	  -- ** Member names
	, MemberName
	, strMemberName
	, mkMemberName
	, mkMemberName_
	) where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)
import qualified Data.Text as T
import Data.Ord (comparing)
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import DBus.Util (checkLength, parseMaybe)
import DBus.Util (mkUnsafe)
import qualified Data.String as String
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString
import qualified Data.ByteString as StrictByteString
import Data.List (intercalate)
import Control.Monad (unless)
import Control.Arrow ((***))
import qualified Data.Map as Map
import Control.Monad (forM)
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)
-- | \"Atomic\" types are any which can't contain any other types. Only
-- atomic types may be used as dictionary keys.
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
-- | Every type has an associated type code; a textual representation of
-- the type, useful for debugging.
typeCode :: Type -> Text
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"
typeCode (DBusArray t) = TL.cons 'a' $ typeCode t
typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]
typeCode (DBusStructure ts) = TL.concat $
	["("] ++ map typeCode ts ++ [")"]
-- | '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.
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
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
-- | 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.
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)
#define INSTANCE_VARIABLE(TYPE) \
	instance Variable TYPE where \
		{ toVariant = VarBox/**/TYPE \
		; fromVariant (VarBox/**/TYPE x) = Just x \
		; fromVariant _ = Nothing \
		}
INSTANCE_VARIABLE(Variant)
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)
instance Variable TL.Text where
	toVariant = VarBoxString
	fromVariant (VarBoxString x) = Just x
	fromVariant _ = Nothing
instance Variable T.Text where
	toVariant = toVariant . TL.fromChunks . (:[])
	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant
instance Variable String where
	toVariant = toVariant . TL.pack
	fromVariant = fmap TL.unpack . fromVariant
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)
strSignature :: Signature -> Text
strSignature (Signature ts) = TL.concat $ map typeCode ts
instance Ord Signature where
	compare = comparing strSignature
mkSignature :: Text -> Maybe Signature
mkSignature text = parsed where
	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
	slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text
	sigParser = do
		types <- P.many parseType
		P.eof
		return $ Signature types
	parseType = parseAtom <|> parseContainer
	parseContainer =
		    parseArray
		<|> parseStruct
		<|> (P.char 'v' >> return DBusVariant)
	parseArray = do
		P.char 'a'
		parseDict <|> fmap DBusArray parseType
	parseDict = do
		P.char '{'
		keyType <- parseAtom
		valueType <- parseType
		P.char '}'
		return $ DBusDictionary keyType valueType
	parseStruct = do
		P.char '('
		types <- P.many parseType
		P.char ')'
		return $ DBusStructure types
	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)
	parsed = case TL.length text of
		0 -> Just $ Signature []
		1 -> fast
		_ -> slow
mkSignature_ :: Text -> Signature
mkSignature_ = mkUnsafe "signature" mkSignature

instance String.IsString Signature where
	fromString = mkSignature_ . TL.pack
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
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
INSTANCE_VARIABLE(Array)
data Array
	= VariantArray Type [Variant]
	| ByteArray ByteString
	deriving (Eq)

-- | This is the type contained within the array, not the type of the array
-- itself.
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
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
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
toArray :: Variable a => Type -> [a] -> Maybe Array
toArray t = arrayFromItems t . map toVariant

fromArray :: Variable a => Array -> Maybe [a]
fromArray = mapM fromVariant . arrayItems
arrayToBytes :: Array -> Maybe ByteString
arrayToBytes (ByteArray x) = Just x
arrayToBytes _             = Nothing

arrayFromBytes :: ByteString -> Array
arrayFromBytes = ByteArray
instance Variable ByteString where
	toVariant = toVariant . arrayFromBytes
	fromVariant x = fromVariant x >>= arrayToBytes
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
INSTANCE_VARIABLE(Dictionary)
data Dictionary = Dictionary
	{ dictionaryKeyType   :: Type
	, dictionaryValueType :: Type
	, dictionaryItems     :: [(Variant, Variant)]
	}
	deriving (Eq)
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) ""
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
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
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
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]
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
INSTANCE_VARIABLE(Structure)
data Structure = Structure [Variant]
	deriving (Show, Eq)
#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
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')
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)
NAME_TYPE(ErrorName, "error name")

mkErrorName :: Text -> Maybe ErrorName
mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName
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)