module Text.RJson (TranslateField,
                   TranslateFieldD,
                   translateField,
                   ToJson,
                   ToJsonD,
                   toJson,
                   exclude,
                   arrayPrepend,
                   arrayAppend,
                   objectExtras,
                   genericToJson,
                   JsonData(..),
                   FromJson,
                   FromJsonD,
                   objectDefaults,
                   parseJsonString,
                   parseJsonByteString,
                   fromJsonString,
                   fromJsonByteString,
                   genericFromJson,
                   stripInitialUnderscores,
                   toJsonString,
                   Union(..), Union3, Union4, Union5, Union6,
                   Union7,Union8,Union9,Union10)
where

import Data.Generics.SYB.WithClass.Basics
import Data.Generics.SYB.WithClass.Instances
import Data.Generics.SYB.WithClass.Context
import Data.Generics.SYB.WithClass.Derive
import qualified Data.Map as M
import qualified Text.Printf as Printf
import Data.Char
import Data.Ratio
import Data.Array
import Data.Maybe
import Control.Monad.State.Strict
import Control.Monad.Trans
import Control.Monad.Error
import qualified Text.ParserCombinators.Parsec as P
import qualified Data.ByteString.Lazy as B
import System.IO.Unsafe
import qualified Control.Exception as E
import Codec.Text.IConv
import qualified Data.Word as W


-- | A Haskell representation of a JSON
--   data structure.
data JsonData = JDString String                       |
                JDNumber Double                       |
                JDArray [JsonData]                    |
                JDBool Bool                           |
                JDObject (M.Map String JsonData)

listJoin :: a -> [a] -> [a]
listJoin _ [] = []
listJoin _ l@[x] = l
listJoin k (x:ys) = x : k : (listJoin k ys)

concatJoin :: String -> [String] -> String
concatJoin k l = concat (listJoin k l)

alistToJsonDict :: [(String, String)] -> String
alistToJsonDict l =
    "{" ++
    concatJoin "," (map (\(k,v) -> (escapeString k) ++ ":" ++ v) l)
    ++ "}"

-- Special characters which will be pretty printed.
escapeMap :: M.Map Char String
escapeMap = M.fromList [
    ('\\', "\\"), ('"', "\""), ('\'', "'"), ('\n', "n"),
    ('\r', "r"), ('\f', "f"), ('\t', "t"), ('\b', "\b")]
escape :: Char -> Maybe String
escape c = M.lookup c escapeMap

-- Characters which can safely be printed as literals.
allowed' c o
  | o > 127 = True -- Any unicode char is OK.
  | o >= 32 && o < 127 {- exclude DEL == 127 -} && c /= '"' = True
  | True = False
allowed c = allowed' c (ord c)

hexEscape :: Char -> String
hexEscape c = Printf.printf "\\u%04x" (ord c)

escapeString' :: String -> String
escapeString' [] = "\""
escapeString' (c:cs)
    | allowed c =
        c : (escapeString' cs)
    | True =
        (maybe (hexEscape c) (\s -> "\\" ++ s) (escape c)) ++
        (escapeString' cs)

escapeString s = '"' : escapeString' s

instance Show JsonData where
    show (JDString s)   = escapeString s
    show (JDNumber n)
        -- Show as an integer if possible, otherwise as a Double.
        -- TODO: Not sure if this is the proper way of testing whether a
        --       double is an integer value +/- epsilon.
        | (fromIntegral (floor n)) == n = show (floor n)
        | True                          = show n
    show (JDBool True)  = "true"
    show (JDBool False) = "false"
    show (JDArray l)    = "[" ++ concatJoin "," (map show l) ++ "]"
    show (JDObject o)   = alistToJsonDict (map (\(k,v) -> (k, show v)) (M.toList o))


--
-- TranslateField class.
--
class TranslateField a where
    -- | By default, Haskell record field names are converted into
    --   JSON object field names by stripping any initial underscores.
    --   Specialize this method to define a different behavior.
    translateField :: a -> String -> String

data TranslateFieldD a = TranslateFieldD { translateFieldD :: a -> String -> String }

translateFieldProxy :: Proxy TranslateFieldD
translateFieldProxy = error "'translateFieldProxy' value should never be evaluated!"

instance (TranslateField t) => Sat (TranslateFieldD t) where
    dict = TranslateFieldD { translateFieldD = translateField }

-- | Removes initial underscores from a string.
stripInitialUnderscores ""      = ""
stripInitialUnderscores ('_':s) = stripInitialUnderscores s
stripInitialUnderscores s       = s

instance (Data TranslateFieldD a) => TranslateField a where
    translateField _ x = stripInitialUnderscores x


--
-- ToJson class plus SYB boilerplate.
--
-- | New instances can be added to this class to customize
--   JSON serialization.
class ToJson a where
    toJson :: a -> JsonData

    -- For lists (same trick used by the Prelude to allow special
    -- handling of list types for Show).
    lToJson  :: [a] -> JsonData
    lToJson l = JDArray (map toJson l)

    -- | You can specialize this method to prevent fields from being serialized.
    --   The method should return a list of the Haskell names of the fields to
    --   be excluded.
    exclude  :: a -> String -> Bool
    exclude _ _ = False

    -- | Types that will be converted to JSON arrays can override
    --   this method to specify additional elements to be prepended to the array.
    arrayPrepend :: a -> [JsonData]
    arrayPrepend _ = []

    -- | Types that will be converted to JSON arrays can override
    --   this method to specify additional elements to be appended to the array.
    arrayAppend :: a -> [JsonData]
    arrayAppend _ = []

    -- | Types that will be converted to JSON objects can override
    --   this method to specify additional fields of the object.
    objectExtras :: a -> [(String, JsonData)]
    objectExtras _ = []

-- Note the inclusion of translateField from TranslateField.
data ToJsonD a = ToJsonD { toJsonD          :: a -> JsonData,
                           excludeD         :: a -> String -> Bool,
                           arrayPrependD    :: a -> [JsonData],
                           arrayAppendD     :: a -> [JsonData],
                           objectExtrasD    :: a -> [(String, JsonData)],
                           translateFieldD' :: a -> String -> String }

toJsonProxy :: Proxy ToJsonD
toJsonProxy = error "'toJsonProxy' value should never be evaluated!"

-- Again, note inclusion of translateField from TranslateField,
-- and TranslateField qualification on variable 't' (in addition
-- to the expected ToJson qualification).
instance (TranslateField t, ToJson t) => Sat (ToJsonD t) where
    dict = ToJsonD { toJsonD          = toJson,
                     excludeD         = exclude,
                     arrayPrependD    = arrayPrepend,
                     arrayAppendD     = arrayAppend,
                     objectExtrasD    = objectExtras,
                     translateFieldD' = translateField }


--
-- Implementations of toJson for different data types.
--
instance ToJson Bool where
    toJson b = JDBool b

instance ToJson Int where
    toJson i = JDNumber (fromIntegral i)
instance ToJson Integer where
    toJson i = JDNumber (fromIntegral i)
--instance Json Float where
--    toJson i = JDNumber (floatToDouble i)
instance ToJson Double where
    toJson i = JDNumber i
instance Integral a => ToJson (Ratio a) where
    toJson i = JDNumber $ (fromIntegral (numerator i)) / (fromIntegral (denominator i))
                        
instance ToJson Char where
    lToJson s = JDString s
    toJson c = JDString [c]

instance ToJson a => ToJson (M.Map String a) where
    toJson x = JDObject (M.map toJson x)

instance (Typeable a, ToJson a) => ToJson [a] where
    toJson = lToJson

-- TODO: Add instances for the other array types supported by GHC.
instance (Typeable a, ToJson a, Ix i) => ToJson (Array i a) where
    toJson a = toJson (elems a)

-- | Use this for merging two or more records together.
--   Sensible instances of FromJson and ToJson are already defined for this type.
data Union a b = Union a b deriving Show
-- | Nested Unions are left-branching by convention (since this is what you get
--   by using the constructor as an infix operator).
type Union3 a b c = (Union (Union a b) c)
type Union4 a b c d = (Union (Union3 a b c) d)
type Union5 a b c d e = (Union (Union4 a b c d) e)
type Union6 a b c d e f = (Union (Union5 a b c d e) f)
type Union7 a b c d e f g = (Union (Union6 a b c d e f) g)
type Union8 a b c d e f g h = (Union (Union7 a b c d e f g) h)
type Union9 a b c d e f g h i = (Union (Union8 a b c d e f g h) i)
type Union10 a b c d e f g h i j = (Union (Union9 a b c d e f g h i) j)

-- Used by the (ToJson Union) instance below.
isJDObject (JDObject _) = True
isJDObject _            = False
jdObjectMap (JDObject m) = m

instance (ToJson a, ToJson b) => ToJson (Union a b) where
    toJson (Union x y) =
        let jx = toJson x
            jy = toJson y
        in
          if isJDObject jx && isJDObject jy
              then JDObject (M.union (jdObjectMap jx) (jdObjectMap jy))
              else error "Bad toJson conversion: Attempt to unify JSON values which aren't both objects"

getFields :: Data ToJsonD a => a -> [String]
getFields = constrFields . (toConstr toJsonProxy)

typename x = dataTypeName (dataTypeOf toJsonProxy x)

-- | This is the implementation of 'toJson' for the generic instance declaration,
-- but it's useful to be able to use the same implentation for
-- other instance declarations which override the default implementation
-- of 'exclude'.
genericToJson :: (Data ToJsonD a, ToJson a, TranslateField a) => a -> JsonData
genericToJson x
        | isAlgType (dataTypeOf toJsonProxy x) =
            case (map (translateFieldD' dict x) (filter (not . (excludeD dict x)) (getFields x))) of
              [] -> JDArray $
                      arrayPrependD dict x ++
                      (JDString (dataTypeName (dataTypeOf toJsonProxy x)) :
                       (gmapQ toJsonProxy (toJsonD dict) x)) ++
                      arrayAppendD dict x
              fs -> JDObject (M.fromList (objectExtrasD dict x ++ (zip fs (gmapQ toJsonProxy (toJsonD dict) x))))
        | True =
            error ("Unable to serialize the primitive type '" ++ typename x ++ "'")

instance (Data ToJsonD t, TranslateField t) => ToJson t where
    toJson = genericToJson

-- Instances for tuples up to n=10.
-- Tuples are converted to (hetrogenous) JSON lists.
instance (ToJson a, ToJson b) => ToJson (a, b) where
    toJson (a,b) = JDArray [toJson a, toJson b]
instance (ToJson a, ToJson b, ToJson c) => ToJson (a,b,c) where
    toJson (a,b,c) = JDArray [toJson a, toJson b, toJson c]
instance (ToJson a, ToJson b, ToJson c, ToJson d) => ToJson (a,b,c,d) where
    toJson (a,b,c,d) = JDArray [toJson a, toJson b, toJson c, toJson d]
instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e) => ToJson (a,b,c,d,e) where
    toJson (a,b,c,d,e) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e]
instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f) =>
         ToJson (a,b,c,d,e,f) where
    toJson (a,b,c,d,e,f) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,
                                   toJson f]
instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f, ToJson g) =>
         ToJson (a,b,c,d,e,f,g) where
    toJson (a,b,c,d,e,f,g) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,
                                     toJson f, toJson g]
instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f, ToJson g, ToJson h) =>
         ToJson (a,b,c,d,e,f,g,h) where
    toJson (a,b,c,d,e,f,g,h) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,
                                       toJson f, toJson g, toJson h]
instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f, ToJson g, ToJson h, ToJson i) =>
         ToJson (a,b,c,d,e,f,g,h,i) where
    toJson (a,b,c,d,e,f,g,h,i) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,
                                         toJson f, toJson g, toJson h, toJson i]
instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f, ToJson g, ToJson h, ToJson i, ToJson j) =>
         ToJson (a,b,c,d,e,f,g,h,i,j) where
    toJson (a,b,c,d,e,f,g,h,i,j) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,
                                           toJson f, toJson g, toJson h, toJson i, toJson j]


--
-- FromJson
--
class FromJson a where
    fromJson :: a -> JsonData -> Either String a

    -- For lists (same trick used by the Prelude to allow special
    -- handling of list types for Show).
    lFromJson :: a -> JsonData -> Either String [a]
    lFromJson dummy (JDArray l) = mapM (fromJson dummy) l

    -- | In order to specify default values for required fields of a JSON object,
    --   specialize this method in the instance definition for the relevant
    --   datatype.
    objectDefaults :: a -> M.Map String JsonData
    objectDefaults _ = M.empty

data FromJsonD a = FromJsonD { fromJsonD         :: a -> JsonData -> Either String a,
                               objectDefaultsD   :: a -> M.Map String JsonData,
                               translateFieldD'' :: a -> String -> String }

fromJsonProxy :: Proxy FromJsonD
fromJsonProxy = error "'fromJsonProxy' should never be evaluated!"

instance (FromJson t, TranslateField t) => Sat (FromJsonD t) where
    dict = FromJsonD { fromJsonD = fromJson,
                       objectDefaultsD = objectDefaults,
                       translateFieldD'' = translateField }

instance FromJson Char where
    fromJson _ (JDString [c]) = Right c
    fromJson _ _              = Left "Bad fromJson conversion: JSON string not of length 1 to 'Char'"

    lFromJson _ (JDString s) = Right s
    lFromJson _ _            = Left "Bad fromJson conversion: Non-string to 'String'"

instance FromJson a => FromJson [a] where
    fromJson _ x = lFromJson undefined x

instance FromJson Int where
    fromJson _ (JDNumber n)
      | (fromIntegral (floor n)) == n = Right (floor n)
      | True =
          Left "Bad fromJson conversion: number does not approximate an integer ('Int')"
    fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to 'Int'"

instance FromJson Integer where
    fromJson _ (JDNumber n)
      | (fromIntegral (floor n)) == n = Right (floor n)
      | True =
          Left "Bad fromJson conversion: number does not approximate an integer ('Integer')"
    fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to 'Integer'"

instance FromJson Double where
    fromJson _ (JDNumber d) = Right d
    fromJson _ _            = Left "Bad fromJson conversion: Non-numeric to 'Double'"

instance Integral a => FromJson (Ratio a) where
    fromJson _ (JDNumber i) = Right (fromRational (toRational i))
    fromJson _ _            = Left "Bad fromJson conversion: Non-numeric to instance of 'Ratio'"

instance FromJson Bool where
    fromJson _ (JDBool b) = Right b
    fromJson _ _          = Left "Bad fromJson conversion: Non-boolean to 'Bool'"

isRight (Right _) = True
isRight _         = False
fromRight (Right x) = x
-- TODO: Use monads instead of 'ifs' if possible (funky type errors
-- which I haven't figured out yet, something to do with monomorphism
-- in let bindings vs. lambda abstraction?).
instance (FromJson a, FromJson b) => FromJson (Union a b) where
    fromJson _ o@(JDObject _) =
        let r1 = fromJson undefined o
            r2 = fromJson undefined o
        in
          if isRight r1 && isRight r2
             then Right $ Union (fromRight r1) (fromRight r2)
             else Left "Bad fromJson conversion: error constructing subpart of union"
    fromJson _ _ = Left "Bad fromJson conversion: attempt to convert non-object to Union"

tuperror :: Int -> Either String a
tuperror n = Left $ Printf.printf "Bad fromJson conversion: attempt to convert something that was not a list of length %i to a %i-tuple" n n

instance (FromJson a, FromJson b) => FromJson (a,b) where
    fromJson _ (JDArray [x1,x2]) = do
      r1 <- fromJson undefined x1
      r2 <- fromJson undefined x2
      return (r1,r2)
    fromJson _ _ = tuperror 2
instance (FromJson a, FromJson b, FromJson c) => FromJson (a,b,c) where
    fromJson _ (JDArray [x1,x2,x3]) = do
      r1 <- fromJson undefined x1
      r2 <- fromJson undefined x2
      r3 <- fromJson undefined x3
      return (r1,r2,r3)
    fromJson _ _ = tuperror 3
instance (FromJson a, FromJson b, FromJson c, FromJson d) => FromJson(a,b,c,d) where
    fromJson _ (JDArray [x1,x2,x3,x4]) = do
      r1 <- fromJson undefined x1
      r2 <- fromJson undefined x2
      r3 <- fromJson undefined x3
      r4 <- fromJson undefined x4
      return (r1,r2,r3,r4)
    fromJson _ _ = tuperror 4
instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e) => FromJson (a,b,c,d,e) where
    fromJson _ (JDArray [x1,x2,x3,x4,x5]) = do
      r1 <- fromJson undefined x1
      r2 <- fromJson undefined x2
      r3 <- fromJson undefined x3
      r4 <- fromJson undefined x4
      r5 <- fromJson undefined x5
      return (r1,r2,r3,r4,r5)
    fromJson _ _ = tuperror 5
instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f) =>
         FromJson (a,b,c,d,e,f) where
    fromJson _ (JDArray [x1,x2,x3,x4,x5,x6]) = do
      r1 <- fromJson undefined x1
      r2 <- fromJson undefined x2
      r3 <- fromJson undefined x3
      r4 <- fromJson undefined x4
      r5 <- fromJson undefined x5
      r6 <- fromJson undefined x6
      return (r1,r2,r3,r4,r5,r6)
    fromJson _ _ = tuperror 6
instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f, FromJson g) =>
         FromJson (a,b,c,d,e,f,g) where
    fromJson _ (JDArray [x1,x2,x3,x4,x5,x6,x7]) = do
      r1 <- fromJson undefined x1
      r2 <- fromJson undefined x2
      r3 <- fromJson undefined x3
      r4 <- fromJson undefined x4
      r5 <- fromJson undefined x5
      r6 <- fromJson undefined x6
      r7 <- fromJson undefined x7
      return (r1,r2,r3,r4,r5,r6,r7)
    fromJson _ _ = tuperror 7
instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f, FromJson g, FromJson h) =>
         FromJson (a,b,c,d,e,f,g,h) where
    fromJson _ (JDArray [x1,x2,x3,x4,x5,x6,x7,x8]) = do
      r1 <- fromJson undefined x1
      r2 <- fromJson undefined x2
      r3 <- fromJson undefined x3
      r4 <- fromJson undefined x4
      r5 <- fromJson undefined x5
      r6 <- fromJson undefined x6
      r7 <- fromJson undefined x7
      r8 <- fromJson undefined x8
      return (r1,r2,r3,r4,r5,r6,r7,r8)
    fromJson _ _ = tuperror 8
instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f, FromJson g, FromJson h, FromJson i) =>
         FromJson (a,b,c,d,e,f,g,h,i) where
    fromJson _ (JDArray [x1,x2,x3,x4,x5,x6,x7,x8,x9]) = do
      r1 <- fromJson undefined x1
      r2 <- fromJson undefined x2
      r3 <- fromJson undefined x3
      r4 <- fromJson undefined x4
      r5 <- fromJson undefined x5
      r6 <- fromJson undefined x6
      r7 <- fromJson undefined x7
      r8 <- fromJson undefined x8
      r9 <- fromJson undefined x9
      return (r1,r2,r3,r4,r5,r6,r7,r8,r9)
    fromJson _ _ = tuperror 9
instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f, FromJson g, FromJson h, FromJson i, FromJson j) =>
         FromJson (a,b,c,d,e,f,g,h,i,j) where
    fromJson _ (JDArray [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10]) = do
      r1 <- fromJson undefined x1
      r2 <- fromJson undefined x2
      r3 <- fromJson undefined x3
      r4 <- fromJson undefined x4
      r5 <- fromJson undefined x5
      r6 <- fromJson undefined x6
      r7 <- fromJson undefined x7
      r8 <- fromJson undefined x8
      r9 <- fromJson undefined x9
      r10 <- fromJson un