{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances,
             OverlappingInstances #-}
-- | 'TNET' is a library that implements the TNET serialization protocol
-- to be used for PGI
-- (<http://code.google.com/p/polyweb/source/browse/doc/PGI.txt>)
-- applications. The TNET protocol
-- (<http://tnetstrings.org>) is designed to be simple to implement in
-- any language, please look at the README for the changes to the
-- original tnetstrings spec.
module TNET
  (
  -- * TNET Parser
    tnetParser
  -- * Classes
  , TNET(..)
  -- * Types
  , TValue
  -- * TNET serialization functions
  , decode
  , encode
  -- * Helpers for defining TNET datatypes
  , dict
  , (.=)
  , (.:)
  ) where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.UTF8 as U

import Data.Attoparsec as P
import Data.Attoparsec.Char8 (char8, endOfLine)
import qualified Data.Attoparsec.Char8 as P8

import Control.Applicative
import Data.Word (Word8)
import Data.Char
import Control.Arrow (second)

-- | A 'TValue' represents a raw TNET object. TNET values
-- are one of the following types:
--
--  * a string of bytes
--
--  * a UTF-8 encoded string
--
--  * an integer
--
--  * a floating point number
--
--  * a boolean
--
--  * null
--
--  * a dictionary type
--
--  * a list of TValues
data TValue = TBytes ByteString
            | TString String
            | TInteger Integer
            | TFloat Double
            | TBool Bool
            | TNull
            | TDict [(String, TValue)]
            | TList [TValue]
            deriving (Eq, Show)

-- | Used to create a TNET dictionary from
-- TNET values. Meant to be used with the
-- '.=' operator as in the following example:
--
-- > myDict = dict [ "a" .= 5
-- >               , "is_dict" .= True
-- >               ]
dict :: [(String, TValue)] -> TValue
dict = TDict

(.=) :: (TNET a) => String -> a -> (String, TValue)
key .= val = (key, toTNET val)

-- | Helper function to extract TNET values from
-- a TNET dictionary. Meant to be used as in the
-- following example:
--
-- > data Person = Person {
-- >                 name :: String
-- >               , age  :: Integer
-- >               }
-- > personFromDict :: TValue -> Maybe Person
-- > personFromDict tdict = do
-- >   name <- tdict .: "name"
-- >   age  <- tdict .: "age"
-- >   return $ Person name age
(.:) :: TNET a => TValue -> String -> Maybe a
(TDict xs) .: key = let lkup = lookup key xs in
                    case lkup of
                      Nothing -> fromTNET TNull
                      Just v  -> fromTNET v
_ .: _            = Nothing

-- | The 'TNET' typeclass represents types that
-- can be encoded and decoded in the TNET format.
-- An example instance:
--
-- > data Person = Person {
-- >                 name :: String
-- >               , age  :: Integer
-- >               }
-- > instance TNET Person where
-- >   toTNET (Person n a) = dict [ "name" .= n
-- >                              , "age"  .= a
-- >                              ]
-- >   fromTNET tval = do
-- >     n <- tval .: "name"
-- >     a <- tval .: "age"
-- >     return $ Person n a
class TNET a where
  toTNET :: a -> TValue
  fromTNET :: TValue -> Maybe a

instance TNET () where
  toTNET = const TNull
  fromTNET TNull = Just ()
  fromTNET _     = Nothing

instance TNET TValue where
  toTNET = id
  fromTNET = Just

instance TNET Integer where
  toTNET = TInteger
  fromTNET (TInteger n) = Just n
  fromTNET _            = Nothing

instance TNET Double where
  toTNET = TFloat
  fromTNET (TFloat n) = Just n
  fromTNET _          = Nothing

instance TNET Bool where
  toTNET = TBool
  fromTNET (TBool b) = Just b
  fromTNET _         = Nothing

instance TNET a => TNET [(String, a)] where
  toTNET = TDict . map (second toTNET)
  fromTNET (TDict d) = mapM (f . second fromTNET) d
                       where f (s, Just x) = Just (s, x)
                             f _           = Nothing
  fromTNET _         = Nothing

instance TNET String where
  toTNET = TString
  fromTNET (TString s) = Just s
  fromTNET _           = Nothing

instance TNET Char where
  toTNET = TString . (:[])
  fromTNET (TString [c]) = Just c
  fromTNET _             = Nothing

instance TNET ByteString where
  toTNET = TBytes
  fromTNET (TBytes b) = Just b
  fromTNET _          = Nothing

instance TNET a => TNET (Maybe a) where
  toTNET = maybe TNull toTNET
  fromTNET TNull = Just Nothing
  fromTNET x     = case fromTNET x of
                     Just val -> Just $ Just val
                     Nothing  -> Nothing

instance TNET a => TNET [a] where
  toTNET = TList . map toTNET
  fromTNET (TList xs) = mapM fromTNET xs
  fromTNET _          = Nothing

dataFromTValue :: TValue -> ByteString
dataFromTValue (TBytes bs)   = bs
dataFromTValue (TString s)   = U.fromString s
dataFromTValue (TBool True)  = "true"
dataFromTValue (TBool False) = "false"
dataFromTValue TNull         = ""
dataFromTValue (TInteger n)  = (B8.pack . show) n
dataFromTValue (TFloat n)    = (B8.pack . show) n
dataFromTValue (TList l)     = B8.concat $ map dumpTNET l
dataFromTValue (TDict m)     = B8.concat $ map dumpPair m

typeFromTValue :: TValue -> ByteString
typeFromTValue (TBytes _)   = ","
typeFromTValue (TString _)  = "$"
typeFromTValue (TBool _)    = "!"
typeFromTValue TNull        = "~"
typeFromTValue (TInteger _) = "#"
typeFromTValue (TFloat _)   = "^"
typeFromTValue (TList _)    = "]"
typeFromTValue (TDict _)    = "}"

dumpPair :: (String, TValue) -> ByteString
dumpPair (key, value) =
  dumpTNET (TString key) `B8.append` dumpTNET value

dumpTNET :: TValue -> ByteString
dumpTNET tval = let t_data = dataFromTValue tval
                    t_size = B8.pack . show $ B8.length t_data
                    t_type = typeFromTValue tval
                in B8.concat [t_size, ":", t_data, t_type]

-- | Encode a Haskell value into the TNET format.
-- Some examples:
--
-- >>> encode 5
-- "1:5#"
--
-- >>> encode "Hello"
-- "5:Hello$"
--
-- >>> encode (-12.3)
-- "5:-12.3^"
--
-- >>> encode ()
-- "0:~"
encode :: TNET a => a -> ByteString
encode = dumpTNET . toTNET

-- | Decode a TNET format bytestring into a Haskell
-- value. An explicit type annotation may be needed
-- if the type of the decoded value can not be
-- determined:
--
-- >>> decode "0:~" :: Maybe ()
-- Just ()
--
-- >>> decode "0:~" :: Maybe (Maybe String)
-- Just Nothing
--
-- >>> decode "1:5#" :: Maybe Integer
-- Just 5
--
-- > let x = decode "4:true!" in
-- > case x of
-- >   Just True  -> putStrLn "got true!"
-- >   Just False -> putStrLn "got false!"
-- >   Nothing    -> putStrLn "error decoding"
decode :: TNET a => ByteString -> Maybe a
decode s = case parse tnetParser s of
             Done _ v -> fromTNET v
             _        -> Nothing

tnetParser :: Parser TValue
tnetParser = do
  size <- P8.decimal <* char8 ':'
  t_data <- P.take size
  t_type <- P8.satisfy $ P8.inClass ",$#^!~}]?"
  case t_type of
    ',' -> return $ TBytes t_data
    '$' -> return $ TString $ U.toString t_data
    '~' -> if size == 0 then return TNull
                        else empty
    '!' -> case parseOnly p_bool t_data of
             Left err -> fail "failed to parse bool"
             Right b -> return b
    '?' -> case parseOnly p_smallbool t_data of
             Left err -> fail "failed to parse bool"
             Right b -> return b
    '#' -> case parseOnly (P8.signed P8.decimal) t_data of
             Left err -> fail "failed to parse integer"
             Right n -> return $ TInteger n
    '^' -> case parseOnly (P8.signed P8.double) t_data of
             Left err -> fail "failed to parse float"
             Right n -> return $ TFloat n
    '}' -> case parseOnly (many p_pair) t_data of
             Left err -> fail "failed to parse dict"
             Right m -> return $ TDict m
    ']' -> case parseOnly (many tnetParser) t_data of
             Left err -> fail "failed to parse list"
             Right m -> return $ TList m
    _   -> empty

p_bool :: Parser TValue
p_bool = (return (TBool True) <* P8.string "true")
     <|> return (TBool False)

p_smallbool :: Parser TValue
p_smallbool = (return (TBool True) <* P8.string "t")
     <|> return (TBool False)

p_pair :: Parser (String, TValue)
p_pair = do
  key <- tnetParser
  value <- tnetParser
  case key of
    TString s -> return (s, value)
    TBytes  s -> return (U.toString s, value)
    _         -> fail "key must be string"