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








instance Variable Variant where                 { toVariant = VarBoxVariant                 ; fromVariant (VarBoxVariant x) = Just x                 ; fromVariant _ = Nothing                 }

instance Variable Bool where                 { toVariant = VarBoxBool                 ; fromVariant (VarBoxBool x) = Just x                 ; fromVariant _ = Nothing                 }
instance Variable Word8 where                 { toVariant = VarBoxWord8                 ; fromVariant (VarBoxWord8 x) = Just x                 ; fromVariant _ = Nothing                 }
instance Variable Int16 where                 { toVariant = VarBoxInt16                 ; fromVariant (VarBoxInt16 x) = Just x                 ; fromVariant _ = Nothing                 }
instance Variable Int32 where                 { toVariant = VarBoxInt32                 ; fromVariant (VarBoxInt32 x) = Just x                 ; fromVariant _ = Nothing                 }
instance Variable Int64 where                 { toVariant = VarBoxInt64                 ; fromVariant (VarBoxInt64 x) = Just x                 ; fromVariant _ = Nothing                 }
instance Variable Word16 where                 { toVariant = VarBoxWord16                 ; fromVariant (VarBoxWord16 x) = Just x                 ; fromVariant _ = Nothing                 }
instance Variable Word32 where                 { toVariant = VarBoxWord32                 ; fromVariant (VarBoxWord32 x) = Just x                 ; fromVariant _ = Nothing                 }
instance Variable Word64 where                 { toVariant = VarBoxWord64                 ; fromVariant (VarBoxWord64 x) = Just x                 ; fromVariant _ = Nothing                 }
instance Variable Double where                 { toVariant = VarBoxDouble                 ; fromVariant (VarBoxDouble x) = Just x                 ; fromVariant _ = Nothing                 }

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 where                 { toVariant = VarBoxSignature                 ; fromVariant (VarBoxSignature x) = Just x                 ; fromVariant _ = Nothing                 }
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 where                 { toVariant = VarBoxObjectPath                 ; fromVariant (VarBoxObjectPath x) = Just x                 ; fromVariant _ = Nothing                 }
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 where                 { toVariant = VarBoxArray                 ; fromVariant (VarBoxArray x) = Just x                 ; fromVariant _ = Nothing                 }
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 where                 { toVariant = VarBoxDictionary                 ; fromVariant (VarBoxDictionary x) = Just x                 ; fromVariant _ = Nothing                 }
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 where                 { toVariant = VarBoxStructure                 ; fromVariant (VarBoxStructure x) = Just x                 ; fromVariant _ = Nothing                 }
data Structure = Structure [Variant]
        deriving (Show, Eq)




















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)