{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

module Network.DBus.Type (
  DBasicType(..),
  DType(..),
  Signature(..),
  hasExcessiveNesting,
  prettyType -- For debugging!
) 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] -- enforce non-empty contents
           | 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)
--      (DTypeStruct t ts)   -> showParen (n > 0) . foldl1 (.) $ map sho (t:ts)
      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

-- parsing of signatures

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 {**}"

-- vim: set sts=2 sw=2 et