# 1 "hs/DBus/Types.cpphs"
# 1 "<built-in>"
# 1 "<command-line>"
# 13 "<command-line>"
# 1 "./dist/build/autogen/cabal_macros.h" 1
# 13 "<command-line>" 2
# 1 "hs/DBus/Types.cpphs"
# 22 "src/types.anansi"
# 30 "src/introduction.anansi"
# 23 "src/types.anansi"
# 52 "src/introduction.anansi"
# 24 "src/types.anansi"
# 358 "src/types.anansi"
# 25 "src/types.anansi"
module DBus.Types (
# 89 "src/types.anansi"
Type (..)
, typeCode
# 165 "src/types.anansi"
, Variant
, Variable (..)
# 234 "src/types.anansi"
, variantType
# 425 "src/types.anansi"
, Signature
, signatureTypes
, strSignature
# 601 "src/types.anansi"
, mkSignature
, mkSignature_
# 658 "src/types.anansi"
, ObjectPath
, strObjectPath
, mkObjectPath
, mkObjectPath_
# 713 "src/types.anansi"
, Array
, arrayType
, arrayItems
# 759 "src/types.anansi"
, toArray
, fromArray
, arrayFromItems
# 777 "src/types.anansi"
, arrayToBytes
, arrayFromBytes
# 846 "src/types.anansi"
, Dictionary
, dictionaryItems
, dictionaryKeyType
, dictionaryValueType
# 923 "src/types.anansi"
, toDictionary
, fromDictionary
, dictionaryFromItems
# 995 "src/types.anansi"
, dictionaryToArray
, arrayToDictionary
# 1011 "src/types.anansi"
, Structure (..)
# 1052 "src/types.anansi"
# 1082 "src/types.anansi"
, BusName
, strBusName
, mkBusName
, mkBusName_
# 1135 "src/types.anansi"
, InterfaceName
, strInterfaceName
, mkInterfaceName
, mkInterfaceName_
# 1176 "src/types.anansi"
, ErrorName
, strErrorName
, mkErrorName
, mkErrorName_
# 1212 "src/types.anansi"
, MemberName
, strMemberName
, mkMemberName
, mkMemberName_
# 27 "src/types.anansi"
) where
# 56 "src/introduction.anansi"
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
# 29 "src/types.anansi"
# 311 "src/types.anansi"
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)
# 345 "src/types.anansi"
import qualified Data.Text as T
# 416 "src/types.anansi"
import Data.Ord (comparing)
# 517 "src/types.anansi"
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import DBus.Util (checkLength, parseMaybe)
# 584 "src/types.anansi"
import DBus.Util (mkUnsafe)
import qualified Data.String as String
# 691 "src/types.anansi"
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString
# 791 "src/types.anansi"
import qualified Data.ByteString as StrictByteString
# 857 "src/types.anansi"
import Data.List (intercalate)
# 874 "src/types.anansi"
import Control.Monad (unless)
# 896 "src/types.anansi"
import Control.Arrow ((***))
import qualified Data.Map as Map
# 908 "src/types.anansi"
import Control.Monad (forM)
# 41 "src/types.anansi"
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)
# 62 "src/types.anansi"
# 27 "src/api-docs.anansi"
# 63 "src/types.anansi"
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
# 83 "src/types.anansi"
# 32 "src/api-docs.anansi"
# 84 "src/types.anansi"
typeCode :: Type -> Text
# 437 "src/types.anansi"
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"
# 456 "src/types.anansi"
typeCode (DBusArray t) = TL.cons 'a' $ typeCode t
# 463 "src/types.anansi"
typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]
# 471 "src/types.anansi"
typeCode (DBusStructure ts) = TL.concat $
["("] ++ map typeCode ts ++ [")"]
# 139 "src/types.anansi"
# 37 "src/api-docs.anansi"
# 140 "src/types.anansi"
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
# 175 "src/types.anansi"
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
# 207 "src/types.anansi"
# 43 "src/api-docs.anansi"
# 208 "src/types.anansi"
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)
# 241 "src/types.anansi"
# 252 "src/types.anansi"
instance Variable Variant where { toVariant = VarBoxVariant ; fromVariant (VarBoxVariant x) = Just x ; fromVariant _ = Nothing }
# 316 "src/types.anansi"
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 }
# 334 "src/types.anansi"
instance Variable TL.Text where
toVariant = VarBoxString
fromVariant (VarBoxString x) = Just x
fromVariant _ = Nothing
# 349 "src/types.anansi"
instance Variable T.Text where
toVariant = toVariant . TL.fromChunks . (:[])
fromVariant = fmap (T.concat . TL.toChunks) . fromVariant
# 362 "src/types.anansi"
instance Variable String where
toVariant = toVariant . TL.pack
fromVariant = fmap TL.unpack . fromVariant
# 395 "src/types.anansi"
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)
# 408 "src/types.anansi"
strSignature :: Signature -> Text
strSignature (Signature ts) = TL.concat $ map typeCode ts
# 420 "src/types.anansi"
instance Ord Signature where
compare = comparing strSignature
# 482 "src/types.anansi"
mkSignature :: Text -> Maybe Signature
mkSignature text = parsed where
# 496 "src/types.anansi"
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
# 485 "src/types.anansi"
# 523 "src/types.anansi"
slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text
sigParser = do
types <- P.many parseType
P.eof
return $ Signature types
# 534 "src/types.anansi"
parseType = parseAtom <|> parseContainer
parseContainer =
parseArray
<|> parseStruct
<|> (P.char 'v' >> return DBusVariant)
# 542 "src/types.anansi"
parseArray = do
P.char 'a'
parseDict <|> fmap DBusArray parseType
parseDict = do
P.char '{'
keyType <- parseAtom
valueType <- parseType
P.char '}'
return $ DBusDictionary keyType valueType
# 556 "src/types.anansi"
parseStruct = do
P.char '('
types <- P.many parseType
P.char ')'
return $ DBusStructure types
# 564 "src/types.anansi"
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)
# 486 "src/types.anansi"
parsed = case TL.length text of
0 -> Just $ Signature []
1 -> fast
_ -> slow
# 589 "src/types.anansi"
mkSignature_ :: Text -> Signature
mkSignature_ = mkUnsafe "signature" mkSignature
instance String.IsString Signature where
fromString = mkSignature_ . TL.pack
# 620 "src/types.anansi"
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
# 647 "src/types.anansi"
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
# 696 "src/types.anansi"
instance Variable Array where { toVariant = VarBoxArray ; fromVariant (VarBoxArray x) = Just x ; fromVariant _ = Nothing }
data Array
= VariantArray Type [Variant]
| ByteArray ByteString
deriving (Eq)
# 49 "src/api-docs.anansi"
# 703 "src/types.anansi"
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
# 723 "src/types.anansi"
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
# 737 "src/types.anansi"
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
# 751 "src/types.anansi"
toArray :: Variable a => Type -> [a] -> Maybe Array
toArray t = arrayFromItems t . map toVariant
fromArray :: Variable a => Array -> Maybe [a]
fromArray = mapM fromVariant . arrayItems
# 768 "src/types.anansi"
arrayToBytes :: Array -> Maybe ByteString
arrayToBytes (ByteArray x) = Just x
arrayToBytes _ = Nothing
arrayFromBytes :: ByteString -> Array
arrayFromBytes = ByteArray
# 785 "src/types.anansi"
instance Variable ByteString where
toVariant = toVariant . arrayFromBytes
fromVariant x = fromVariant x >>= arrayToBytes
# 795 "src/types.anansi"
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
# 836 "src/types.anansi"
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)
# 861 "src/types.anansi"
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) ""
# 878 "src/types.anansi"
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
# 901 "src/types.anansi"
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
# 912 "src/types.anansi"
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
# 972 "src/types.anansi"
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]
# 980 "src/types.anansi"
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
# 1005 "src/types.anansi"
instance Variable Structure where { toVariant = VarBoxStructure ; fromVariant (VarBoxStructure x) = Just x ; fromVariant _ = Nothing }
data Structure = Structure [Variant]
deriving (Show, Eq)
# 1031 "src/types.anansi"
# 1049 "src/types.anansi"
# 1068 "src/types.anansi"
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')
# 1123 "src/types.anansi"
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)
# 1169 "src/types.anansi"
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
# 1201 "src/types.anansi"
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)