module Network.DBus.Type (
DBasicType(..),
DType(..),
Signature(..),
hasExcessiveNesting,
prettyType
) where
import Data.List (intersperse)
import Data.Typeable (Typeable)
import Data.Maybe (fromJust)
import Text.ParserCombinators.Parsec
import qualified Data.Map as M
data DBasicType = DTypeByte
| DTypeBoolean
| DTypeInt16
| DTypeInt32
| DTypeInt64
| DTypeUInt16
| DTypeUInt32
| DTypeUInt64
| DTypeDouble
| DTypeString
| DTypeObjectPath
| DTypeSignature
deriving (Eq, Ord, Typeable)
data DType = DBasicType DBasicType
| DTypeArray DType
| DTypeStruct DType [DType]
| DTypeVariant
| DTypeDictEntry DBasicType DType
deriving (Eq, Ord, Typeable)
newtype Signature = Signature [DType]
deriving (Eq, Ord, Typeable)
instance Show Signature where
show (Signature ts) = ts >>= show
instance Read Signature where
readsPrec _ s =
case tryParseSignature s of
Left _ -> []
Right t -> [(t,"")]
hasExcessiveNesting :: DType -> Bool
hasExcessiveNesting v =
let hen a s t =
if (a > 32 || s > 32)
then True
else case t of
(DTypeArray u) -> hen (a + 1) s u
(DTypeStruct u us) -> any (hen a (s + 1)) (u:us)
(DTypeDictEntry _ u) -> hen a s u
_ -> False
in hen (0 :: Int) (0 :: Int) v
instance Show DBasicType where
show DTypeByte = "y"
show DTypeBoolean = "b"
show DTypeInt16 = "n"
show DTypeUInt16 = "q"
show DTypeInt32 = "i"
show DTypeUInt32 = "u"
show DTypeInt64 = "x"
show DTypeUInt64 = "t"
show DTypeDouble = "d"
show DTypeString = "s"
show DTypeObjectPath = "o"
show DTypeSignature = "g"
instance Show DType where
showsPrec _n t = case t of
(DBasicType b) -> sho b
(DTypeArray s) -> showChar 'a' . sho s
(DTypeVariant) -> showChar 'v'
(DTypeDictEntry k v) -> showChar '{' . sho k . sho v . showChar '}'
(DTypeStruct u us) -> showParen True . foldl1 (.) $ map sho (u:us)
where sho :: Show a => a -> ShowS
sho = showsPrec 1
instance Read DType where
readsPrec _ ty = case tryParseSingleType ty of
Left _ -> []
Right t -> [(t,"")]
class PrettyType t where
prettyType :: t -> String
pp :: PrettyType t => t -> String
pp = prettyType
instance PrettyType DBasicType where
prettyType t = case t of
DTypeByte -> "Byte"
DTypeBoolean -> "Boolean"
DTypeInt16 -> "Int16"
DTypeUInt16 -> "UInt16"
DTypeInt32 -> "Int32"
DTypeUInt32 -> "UInt32"
DTypeInt64 -> "Int64"
DTypeUInt64 -> "UInt64"
DTypeDouble -> "Double"
DTypeString -> "String"
DTypeObjectPath -> "ObjectPath"
DTypeSignature -> "Signature"
instance PrettyType DType where
prettyType ct = case ct of
(DBasicType t) -> prettyType t
(DTypeArray t) -> "Array of " ++ pp t
(DTypeStruct t ts) -> "Struct of ("
++ (glueWith ", " $ map pp (t:ts))
++ ")"
(DTypeVariant) -> "Variant"
(DTypeDictEntry k v) -> "DictEntry " ++ pp k ++ " => " ++ pp v
where glueWith x = concat . intersperse x
tryParseSignature :: String -> Either ParseError Signature
tryParseSignature = parse parseSignature "<signature>"
parseSignature :: Parser Signature
parseSignature = do (t:ts) <- many1 parseType <?> "at least one type"
eof
return (Signature (t:ts))
tryParseSingleType :: String -> Either ParseError DType
tryParseSingleType = parse parseSingleType "<type>"
parseSingleType :: Parser DType
parseSingleType = do t <- parseType <?> "a single type"
eof
return t
parseType :: Parser DType
parseType = choice [ parseBasicTypeWrapped
, parseArray
, parseStruct
, parseVariant
]
parseBasicTypeWrapped :: Parser DType
parseBasicTypeWrapped = do bt <- parseBasicType
return $ DBasicType bt
basicTypes :: M.Map Char DBasicType
basicTypes = M.fromList [ ('y', DTypeByte)
, ('b', DTypeBoolean)
, ('n', DTypeInt16)
, ('q', DTypeUInt16)
, ('i', DTypeInt32)
, ('u', DTypeUInt32)
, ('x', DTypeInt64)
, ('t', DTypeUInt64)
, ('d', DTypeDouble)
, ('s', DTypeString)
, ('o', DTypeObjectPath)
, ('g', DTypeSignature)
]
parseBasicType :: Parser DBasicType
parseBasicType = do c <- oneOf sekritCodes
return . fromJust $ M.lookup c basicTypes
<?> "basic type [one of " ++ sekritCodes ++ "]"
where sekritCodes = M.keys basicTypes
parseArray :: Parser DType
parseArray = do char 'a'
t <- (parseType <?> "array contents type")
<|>
(parseDictEntry)
return $ DTypeArray t
<?> "array a*"
parseStruct :: Parser DType
parseStruct = do char '('
(t:ts) <- many1 parseType
<?> "at least one type within the struct"
char ')' <?> "closing paren for struct"
return $ DTypeStruct t ts
<?> "struct (*)"
parseVariant :: Parser DType
parseVariant = do char 'v'
return DTypeVariant
<?> "variant v"
parseDictEntry :: Parser DType
parseDictEntry = do char '{'
k <- parseBasicType <?> "basic type (as dict key)"
v <- parseType <?> "dict value type"
char '}' <?> "closing brace of dict entry"
return $ DTypeDictEntry k v
<?> "dict entry {**}"