{-
  Copyright (C) 2009 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 DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}

{-# 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.Typeable (Typeable, cast)

import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)

import qualified Data.Text as T

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 ++ [")"]


class (Show a, Eq a) => Builtin a where
        builtinDBusType :: a -> Type

-- | '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 = forall a. (Variable a, Builtin a, Typeable a) => Variant a
        deriving (Typeable)

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

instance Show Variant where
        showsPrec d (Variant x) = showParen (d > 10) $
                s "Variant " . shows code . s " " . showsPrec 11 x
                where code = typeCode . builtinDBusType $ x
                      s    = showString

instance Eq Variant where
        (Variant x) == (Variant y) = cast x == Just y

-- | 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 (Variant x) = builtinDBusType x














instance Builtin Variant where                 { builtinDBusType _ = DBusVariant };         instance Variable Variant where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };

instance Builtin Bool where                 { builtinDBusType _ = DBusBoolean };         instance Variable Bool where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
instance Builtin Word8 where                 { builtinDBusType _ = DBusByte };         instance Variable Word8 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
instance Builtin Int16 where                 { builtinDBusType _ = DBusInt16 };         instance Variable Int16 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
instance Builtin Int32 where                 { builtinDBusType _ = DBusInt32 };         instance Variable Int32 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
instance Builtin Int64 where                 { builtinDBusType _ = DBusInt64 };         instance Variable Int64 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
instance Builtin Word16 where                 { builtinDBusType _ = DBusWord16 };         instance Variable Word16 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
instance Builtin Word32 where                 { builtinDBusType _ = DBusWord32 };         instance Variable Word32 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
instance Builtin Word64 where                 { builtinDBusType _ = DBusWord64 };         instance Variable Word64 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
instance Builtin Double where                 { builtinDBusType _ = DBusDouble };         instance Variable Double where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };

instance Builtin TL.Text where                 { builtinDBusType _ = DBusString };         instance Variable TL.Text where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };

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 Builtin Signature where                 { builtinDBusType _ = DBusSignature };         instance Variable Signature where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
data Signature = Signature { signatureTypes :: [Type] }
        deriving (Eq, Typeable)

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 x y = compare (strSignature x) (strSignature y)

mkSignature :: Text -> Maybe Signature
mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where
        sigParser = do
                types <- P.many parseType
                P.eof
                return $ Signature types
        parseType = parseAtom <|> parseContainer
        parseContainer =
                    parseArray
                <|> parseStruct
                <|> (P.char 'v' >> return DBusVariant)
        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)
        parseArray = do
                P.char 'a'
                parseDict <|> do
                t <- parseType
                return $ DBusArray t
        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

mkSignature_ :: Text -> Signature
mkSignature_ = mkUnsafe "signature" mkSignature

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

instance Builtin ObjectPath where                 { builtinDBusType _ = DBusObjectPath };         instance Variable ObjectPath where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
newtype ObjectPath = ObjectPath
        { strObjectPath :: Text
        }
        deriving (Eq, Ord, Typeable)

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 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
data Array
        = VariantArray Type [Variant]
        | ByteArray ByteString
        deriving (Eq, Typeable)

instance Builtin Array where
        builtinDBusType = DBusArray . arrayType

-- | 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
                        vs = [show x | (Variant x) <- arrayItems array]
                        valueString = intercalate ", " vs

arrayFromItems :: Type -> [Variant] -> Maybe Array
arrayFromItems DBusByte vs = do
        bytes <- mapM fromVariant vs
        Just . ByteArray . ByteString.pack $ bytes

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 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
data Dictionary = Dictionary
        { dictionaryKeyType   :: Type
        , dictionaryValueType :: Type
        , dictionaryItems     :: [(Variant, Variant)]
        }
        deriving (Eq, Typeable)

instance Builtin Dictionary where
        builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt

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 ((Variant k), (Variant v)) =
                                show k ++ " -> " ++ show 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 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
data Structure = Structure [Variant]
        deriving (Show, Eq, Typeable)

instance Builtin Structure where
        builtinDBusType (Structure vs) = DBusStructure $ map variantType vs




















newtype BusName = BusName {strBusName :: Text}                 deriving (Eq, Ord);                         instance Show BusName where                 { showsPrec d (BusName x) = showParen (d > 10) $                         showString "BusName " . shows x                 };                         instance String.IsString BusName where                 { fromString = mkBusName_ . TL.pack };                         instance Variable BusName where                 { toVariant = toVariant . strBusName                 ; fromVariant = (mkBusName =<<) . fromVariant };                                                                         mkBusName_ :: Text -> BusName;         mkBusName_ = mkUnsafe "bus name" mkBusName

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')

newtype InterfaceName = InterfaceName {strInterfaceName :: Text}                 deriving (Eq, Ord);                         instance Show InterfaceName where                 { showsPrec d (InterfaceName x) = showParen (d > 10) $                         showString "InterfaceName " . shows x                 };                         instance String.IsString InterfaceName where                 { fromString = mkInterfaceName_ . TL.pack };                         instance Variable InterfaceName where                 { toVariant = toVariant . strInterfaceName                 ; fromVariant = (mkInterfaceName =<<) . fromVariant };                                                                         mkInterfaceName_ :: Text -> InterfaceName;         mkInterfaceName_ = mkUnsafe "interface name" mkInterfaceName

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)

newtype ErrorName = ErrorName {strErrorName :: Text}                 deriving (Eq, Ord);                         instance Show ErrorName where                 { showsPrec d (ErrorName x) = showParen (d > 10) $                         showString "ErrorName " . shows x                 };                         instance String.IsString ErrorName where                 { fromString = mkErrorName_ . TL.pack };                         instance Variable ErrorName where                 { toVariant = toVariant . strErrorName                 ; fromVariant = (mkErrorName =<<) . fromVariant };                                                                         mkErrorName_ :: Text -> ErrorName;         mkErrorName_ = mkUnsafe "error name" mkErrorName

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

newtype MemberName = MemberName {strMemberName :: Text}                 deriving (Eq, Ord);                         instance Show MemberName where                 { showsPrec d (MemberName x) = showParen (d > 10) $                         showString "MemberName " . shows x                 };                         instance String.IsString MemberName where                 { fromString = mkMemberName_ . TL.pack };                         instance Variable MemberName where                 { toVariant = toVariant . strMemberName                 ; fromVariant = (mkMemberName =<<) . fromVariant };                                                                         mkMemberName_ :: Text -> MemberName;         mkMemberName_ = mkUnsafe "member name" mkMemberName

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)