-- 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.Internal 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 Data.Text.Encoding (decodeUtf8)
import qualified Data.ByteString.Unsafe as B
import qualified Foreign as F
import System.IO.Unsafe (unsafePerformIO)
import Data.Text.Lazy.Encoding (encodeUtf8)
import DBus.Util (mkUnsafe)
import qualified Data.String as String
import Text.ParserCombinators.Parsec ((<|>))
import qualified Text.ParserCombinators.Parsec as P
import DBus.Util (checkLength, parseMaybe)
import Data.List (intercalate)
import Control.Monad (unless)
import Control.Arrow ((***))
import qualified Data.Map as Map
import Control.Monad (forM)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BL8
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 t = TL.fromChunks [decodeUtf8 $ typeCodeB t]

typeCodeB :: Type -> B.ByteString
typeCodeB DBusBoolean    = "b"
typeCodeB DBusByte       = "y"
typeCodeB DBusInt16      = "n"
typeCodeB DBusInt32      = "i"
typeCodeB DBusInt64      = "x"
typeCodeB DBusWord16     = "q"
typeCodeB DBusWord32     = "u"
typeCodeB DBusWord64     = "t"
typeCodeB DBusDouble     = "d"
typeCodeB DBusString     = "s"
typeCodeB DBusSignature  = "g"
typeCodeB DBusObjectPath = "o"
typeCodeB DBusVariant    = "v"
typeCodeB (DBusArray t) = B8.cons 'a' $ typeCodeB t
typeCodeB (DBusDictionary k v) = B.concat ["a{", typeCodeB k, typeCodeB v, "}"]
typeCodeB (DBusStructure ts) = B.concat $
	["("] ++ map typeCodeB 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)

variantSignature :: Variant -> Maybe Signature
variantSignature = mkBytesSignature . typeCodeB . variantType
#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)
bytesSignature :: Signature -> B.ByteString
bytesSignature (Signature ts) = B.concat $ map typeCodeB ts

strSignature :: Signature -> Text
strSignature (Signature ts) = TL.concat $ map typeCode ts
instance Ord Signature where
	compare = comparing strSignature
mkBytesSignature :: B.ByteString -> Maybe Signature
mkBytesSignature = unsafePerformIO . flip B.unsafeUseAsCStringLen io where
	parseAtom c yes no = case c of
		0x62 -> yes DBusBoolean
		0x79 -> yes DBusByte
		0x6E -> yes DBusInt16
		0x69 -> yes DBusInt32
		0x78 -> yes DBusInt64
		0x71 -> yes DBusWord16
		0x75 -> yes DBusWord32
		0x74 -> yes DBusWord64
		0x64 -> yes DBusDouble
		0x73 -> yes DBusString
		0x67 -> yes DBusSignature
		0x6F -> yes DBusObjectPath
		_ -> no
	
	fast c = parseAtom c (\t -> Just (Signature [t])) $ case c of
		0x76 -> Just (Signature [DBusVariant])
		_ -> Nothing
	slow :: F.Ptr Word8 -> Int -> IO (Maybe Signature)
	slow buf len = loop [] 0 where
		loop acc ii | ii >= len = return . Just . Signature $ reverse acc
		loop acc ii = do
			c <- F.peekElemOff buf ii
			let next t = loop (t : acc) (ii + 1)
			parseAtom c next $ case c of
				0x76 -> next DBusVariant
				
				-- '('
				0x28 -> do
					mt <- structure buf len (ii + 1)
					case mt of
						Just (ii', t) -> loop (t : acc) ii'
						Nothing -> return Nothing
				
				-- 'a'
				0x61 -> do
					mt <- array buf len (ii + 1)
					case mt of
						Just (ii', t) -> loop (t : acc) ii'
						Nothing -> return Nothing
				
				_ -> return Nothing
	structure :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))
	structure buf len = loop [] where
		loop _ ii | ii >= len = return Nothing
		loop acc ii = do
			c <- F.peekElemOff buf ii
			let next t = loop (t : acc) (ii + 1)
			parseAtom c next $ case c of
				0x76 -> next DBusVariant
				
				-- '('
				0x28 -> do
					mt <- structure buf len (ii + 1)
					case mt of
						Just (ii', t) -> loop (t : acc) ii'
						Nothing -> return Nothing
				
				-- ')'
				0x29 -> return $ Just $ (ii + 1, DBusStructure (reverse acc))
				
				-- 'a'
				0x61 -> do
					mt <- array buf len (ii + 1)
					case mt of
						Just (ii', t) -> loop (t : acc) ii'
						Nothing -> return Nothing
				
				_ -> return Nothing
	array :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))
	array _   len ii | ii >= len = return Nothing
	array buf len ii = do
		c <- F.peekElemOff buf ii
		let next t = return $ Just (ii + 1, DBusArray t)
		parseAtom c next $ case c of
			0x76 -> next DBusVariant
			
			-- '('
			0x28 -> do
				mt <- structure buf len (ii + 1)
				case mt of
					Just (ii', t) -> return $ Just (ii', DBusArray t)
					Nothing -> return Nothing
			
			-- '{'
			0x7B -> dict buf len (ii + 1)
			
			-- 'a'
			0x61 -> do
				mt <- array buf len (ii + 1)
				case mt of
					Just (ii', t) -> return $ Just (ii', DBusArray t)
					Nothing -> return Nothing
			
			_ -> return Nothing
	dict :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))
	dict _   len ii | ii + 1 >= len = return Nothing
	dict buf len ii = do
		c1 <- F.peekElemOff buf ii
		c2 <- F.peekElemOff buf (ii + 1)
		
		let mt1 = parseAtom c1 Just Nothing
		
		let next t = return $ Just (ii + 2, t)
		mt2 <- parseAtom c2 next $ case c2 of
			0x76 -> next DBusVariant
			
			-- '('
			0x28 -> structure buf len (ii + 2)
			
			-- 'a'
			0x61 -> array buf len (ii + 2)
			
			_ -> return Nothing
		
		case mt2 of
			Nothing -> return Nothing
			Just (ii', t2) -> if ii' >= len
				then return Nothing
				else do
					c3 <- F.peekElemOff buf ii'
					return $ do
						if c3 == 0x7D then Just () else Nothing
						t1 <- mt1
						Just (ii' + 1, DBusDictionary t1 t2)
	
	io (cstr, len) = case len of
		0 -> return $ Just $ Signature []
		1 -> fmap fast $ F.peek cstr
		_ | len <= 255 -> slow (F.castPtr cstr) len
		_ -> return Nothing
mkSignature :: Text -> Maybe Signature
mkSignature = mkBytesSignature . B.concat . BL.toChunks . encodeUtf8
mkSignature_ :: Text -> Signature
mkSignature_ = mkUnsafe "signature" mkSignature

instance String.IsString Signature where
	fromString = mkUnsafe "signature" mkBytesSignature . BL8.pack
maybeValidType :: Type -> Maybe ()
maybeValidType t = if B.length (typeCodeB t) > 255
	then Nothing
	else Just ()
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 BL.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 $ BL.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 . BL.pack) (mapM fromVariant vs)

arrayFromItems t vs = do
	maybeValidType 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 BL.ByteString
arrayToBytes (ByteArray x) = Just x
arrayToBytes _             = Nothing

arrayFromBytes :: BL.ByteString -> Array
arrayFromBytes = ByteArray
instance Variable BL.ByteString where
	toVariant = toVariant . arrayFromBytes
	fromVariant x = fromVariant x >>= arrayToBytes
instance Variable B.ByteString where
	toVariant x = toVariant . arrayFromBytes $ BL.fromChunks [x]
	fromVariant = fmap (B.concat . BL.toChunks) . fromVariant
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
	maybeValidType kt
	maybeValidType 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)