{-
  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

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

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

typeCode :: Type -> Text

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

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

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)

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

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 Builtin ObjectPath where                 { builtinDBusType _ = DBusObjectPath };         instance Variable ObjectPath where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };
newtype ObjectPath = ObjectPath
        { strObjectPath :: Text
        }
        deriving (Show, Eq, Ord, Typeable)

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 = Array
        { arrayType  :: Type
        , arrayItems :: [Variant]
        }
        deriving (Eq, Typeable)

instance Builtin Array where
        builtinDBusType = DBusArray . arrayType

instance Show Array where
        showsPrec d (Array t vs) = showParen (d > 10) $
                s "Array " . showSig . s " [" . s valueString . s "]" where
                        s = showString
                        showSig = shows $ typeCode t
                        vs' = [show x | (Variant x) <- vs]
                        valueString = intercalate ", " vs'

arrayFromItems :: Type -> [Variant] -> Maybe Array
arrayFromItems t vs = do
        mkSignature (typeCode t)
        if all (\x -> variantType x == t) vs
                then Just $ Array 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

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 t items) = do
        let toPair x = do
                struct <- fromVariant x
                case struct of
                        Structure [k, v] -> Just (k, v)
                        _                -> Nothing
        (kt, vt) <- case t of
                DBusStructure [kt, vt] -> Just (kt, vt)
                _                      -> Nothing
        pairs <- mapM toPair items
        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 (Show, Eq, Ord);                                                   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 (Show, Eq, Ord);                                                   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 (Show, Eq, Ord);                                                   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 (Show, Eq, Ord);                                                   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)