RJson-0.2: Text/RJson.hs

{-# OPTIONS_GHC -XFlexibleInstances -XOverlappingInstances -XMultiParamTypeClasses -XFlexibleContexts -XUndecidableInstances -XTemplateHaskell #-}

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
              [] -> case gmapQ toJsonProxy (toJsonD dict) x of
                      l  -> JDArray $ (arrayPrependD dict x) ++ l ++ (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 undefined x10
      return (r1,r2,r3,r4,r5,r6,r7,r8,r9,r10)
    fromJson _ _ = tuperror 10

elemsOfMap :: Ord k => M.Map k v -> [k] -> Maybe [v]
elemsOfMap _ [] = Just []
elemsOfMap m (x:xs) = do
  r <- M.lookup x m
  rs <- elemsOfMap m xs
  return (r : rs)

type ErrorWithState e s a = ErrorT e (State s) a

-- TODO: Not a very descriptive name. Oh well...
m1 :: (Data FromJsonD a) => a -> ErrorWithState String [JsonData] a
m1 dummy = do
  jvl <- lift get
  (case jvl of
     []       -> throwError "Bad fromJson conversion: Not enough elements in JSON array to satisfy constructor"
     (jv:jvs) -> do
       lift $ put jvs
       (case fromJsonD dict dummy jv of
          Left e  -> throwError e
          Right x -> return x))

-- TODO: Again, uninformative name.
-- TODO: Some code duplication here.
m2 :: (Data FromJsonD a) => M.Map String JsonData -> a -> ErrorWithState String (M.Map String JsonData, [String]) a
m2 defaults dummy = do
  (m, sl) <- lift get
  (case sl of
     []     -> throwError "Bad fromJson conversion: Not enough fields in JSON object to satisfy constructor"
     (f:fs) -> do
       lift $ put (m, fs)
       let stripped = translateFieldD'' dict dummy f
       (case M.lookup stripped m of
          Nothing ->
            case M.lookup stripped defaults of
              Nothing -> throwError $  "Bad fromJson conversion: Required field not present in JSON object" ++ stripped
              Just v  ->
                case fromJsonD dict dummy v of
                  Left e  -> throwError e
                  Right x -> return x
          Just v ->
            case fromJsonD dict dummy v of
              Left e  -> throwError e
              Right x -> return x))

genericFromJson :: (Data FromJsonD a, Data TranslateFieldD a) => a -> JsonData -> Either String a
genericFromJson dummy (JDArray l) =
    case datarep (dataTypeOf fromJsonProxy dummy) of
      AlgRep (c:_) ->
          evalState (runErrorT (gmapM fromJsonProxy m1 (fromConstr fromJsonProxy c))) (tail l)
      AlgRep _     -> Left "Bad fromJson conversion: Type with no constructors!"
      _            -> Left "Bad fromJson conversion: Non-algebraic datatype given to 'genericFromJson'"
genericFromJson dummy (JDObject m) =
    case datarep (dataTypeOf fromJsonProxy dummy) of
      AlgRep (c:_) ->
          case constrFields c of
            [] -> Left "Bad fromJson conversion: Attempt to convert JDObect to a non-record algebraic type"
            fs -> evalState (runErrorT (gmapM fromJsonProxy (m2 (objectDefaultsD dict dummy)) (fromConstr fromJsonProxy c))) (m, fs)
      AlgRep _     -> Left "Bad fromJson conversion: Type with no constructors!"
      _            -> Left "Bad fromJson conversion: Non-algebraic datatype given to 'genericFromJson'"
genericFromJson _ _ = Left "Bad fromJson conversion: Expecting JSON object or array"
          
instance (Data FromJsonD t, Data TranslateFieldD t) => FromJson t where
    fromJson = genericFromJson


--
-- JSON parser.
--

-- Determine the unicode encoding of a byte stream
-- on the assumption that it begins with two ASCII characters.
getEncoding :: B.ByteString -> EncodingName
getEncoding s
  | B.length s < 4 = "UTF-8" -- If the string is shorter than 4 bytes,
                             -- we have no way of determining the encoding.
  | True =
      let bs1 = B.index s 0
          bs2 = B.index s 1
          bs3 = B.index s 2
          bs4 = B.index s 3
      in
        -- Little endian UTF 32/16.
        if bs1 /= 0 && bs2 == 0 && bs3 == 0 && bs4 == 0
        then "UTF-32LE"
        else if bs1 /= 0 && bs2 == 0 && bs3 /= 0 && bs4 == 0
        then "UTF-16LE"
        -- Big endian UTF 32/16.
        else if bs1 == 0 && bs2 == 0 && bs3 == 0 && bs4 /= 0
        then "UTF-32BE"
        else if bs1 == 0 && bs2 /= 0 && bs3 == 0 && bs4 /= 0
        then "UTF-16BE"
        -- UTF-8
        else if bs1 /= 0 && bs2 /= 0 && bs3 /= 0 && bs4 /= 0
        then "UTF-8" -- BOM allowed but not required for UTF-8.
        -- If we can't figure it out, guess at UTF-8.
        else "UTF-8"

-- Converts a String of byte values of given encoding to a String of unicode code points.
toHaskellString :: EncodingName -> B.ByteString -> String
toHaskellString enc source =
    stripBOM $ map chr (pairBytes (B.unpack bs))
    where
      pairBytes :: [W.Word8] -> [Int]
      pairBytes [] = []
      pairBytes (c:c':cs) = ((fromIntegral c) + (fromIntegral c')*256) : (pairBytes cs)
      bs = convertFuzzy Discard enc "UTF-16LE" source

stripBOM :: String -> String
stripBOM ('\0':'\0':'\xFE':'\xFF':cs) = cs
stripBOM ('\xFF':'\xFE':'\0':'\0':cs) = cs
stripBOM ('\xFE':'\xFF':cs)           = cs
stripBOM ('\xFF':'\xFE':cs)           = cs
stripBOM ('\xEF':'\xBB':'\xBF':cs)    = cs
stripBOM cs                           = cs

(<|>) = (P.<|>)

-- | Converts a ByteString to an instance of JsonData (unicode encoding
--   is detected automatically).
parseJsonByteString :: B.ByteString -> Either String JsonData
parseJsonByteString bs =
    let
        decoded = toHaskellString (getEncoding bs) bs
    in
      case P.runParser (ws >> jsonValue) () "" decoded of
        Left e -> Left (show e)
        Right x -> Right x

-- | Converts a String (interpreted as a true unicode String) to an instance
--   of JsonData.
parseJsonString :: String -> Either String JsonData
parseJsonString s =
    case P.runParser (ws >> jsonValue) () "" s of
      Left e -> Left (show e)
      Right x -> Right x

apply f p = do
  r <- p
  return (f r)

pconcat p1 p2 = do
  l1 <- p1
  l2 <- p2
  return $ l1 ++ l2

listify :: P.Parser x -> P.Parser [x]
listify = apply (:[])

ws = P.many (P.oneOf [' ','\r','\n','\t','\f','\v'])

-- Could use the ParsecToken module, but trying a floating point number
-- then an integer is a bit inefficient (especially since integers will
-- be more common).
number :: P.Parser JsonData
number = do
  i <- P.many1 P.digit
  point <- P.option Nothing (apply Just (P.char '.' >> P.many1 P.digit))
  exponent <- P.option Nothing (apply Just (P.char 'e' >> pconcat (P.option "" (listify (P.char '-'))) (P.many1 P.digit)))
  (if point == Nothing && exponent == Nothing
      then return (JDNumber (read i :: Double))
      else return (
          JDNumber (
              read (i ++ (if point == Nothing then "" else "." ++ fromJust point) ++
                         (if exponent == Nothing then "" else "e" ++ fromJust exponent))
              :: Double
      )))

stringChar :: Char -> P.Parser Char
stringChar opener = do
  -- Fail immediately on either single or double quotes or
  -- on control characters.
  c <- P.satisfy (\c -> c /= opener && (ord c) > 31)
  (case c of
     '\\' ->
         (P.char '"' >> return '"')   <|>
         (P.char '\'' >> return '\'') <|>
         (P.char 'b' >> return '\b')  <|>
         (P.char 'f' >> return '\f')  <|>
         (P.char 'n' >> return '\n')  <|>
         (P.char 'r' >> return '\r')  <|>
         (P.char 't' >> return '\t')  <|>
         (do
           P.char 'u'
           ds <- P.count 4 P.hexDigit
           return $ chr (read ("0x" ++ ds) :: Int)) <|>
         (P.satisfy allowed >>= return) -- "\X" == "X" by default.
     c -> return c)

string :: P.Parser String
string = do
  opener <- P.char '"' <|> P.char '\'' -- JSON spec requires double quotes, but we'll be lenient.
  cs <- P.many (stringChar opener)
  P.char opener
  return cs

jsonString = apply JDString string

kvp :: P.Parser (String, JsonData)
kvp = do
  s <- string
  ws
  P.char ':'
  ws
  v <- jsonValue
  return (s, v)

jsonArray :: P.Parser JsonData
jsonArray = do
  P.char '['
  ws
  vs <- P.sepBy jsonValue (ws >> P.char ',' >> ws)
  ws
  P.char ']'
  return $ JDArray vs

object :: P.Parser JsonData
object = do
    P.char '{'
    ws
    kvps <- P.sepBy kvp (ws >> P.char ',' >> ws)
    ws
    P.char '}'
    return $ JDObject $ M.fromList kvps

boolean :: P.Parser JsonData
boolean = (P.try (P.string "true") >> return (JDBool True)) <|>
          (P.string "false" >> return (JDBool False))

jsonValue = number <|> jsonString <|> jsonArray <|> object <|> boolean


--
-- Some other utilities.
--
-- | Converts a JSON String (interpreted as a true unicode string) to
--   a value of the type given by the first (dummy) argument.
fromJsonString :: FromJson a => a -> String -> Either String a
fromJsonString dummy s =
    case parseJsonString s of
      Left e -> Left (show e)
      Right js ->
          case fromJson dummy js of
            Left e -> Left e
            Right js -> Right js

-- | Converts a JSON ByteString (with unicode encoding automatically detected)
--   to a value of the type given by the first (dummy) argument.
fromJsonByteString :: FromJson a => a -> B.ByteString -> Either String a
fromJsonByteString dummy s =
    case parseJsonByteString s of
      Left e -> Left (show e)
      Right js ->
          case fromJson dummy js of
            Left e -> Left e
            Right js -> Right js

-- | Converts a value to an ASCII-only JSON String.
toJsonString :: ToJson a => a -> String
toJsonString = show . toJson

data Test = Foo | Bar deriving Show
$(derive[''Test])
data Test2 = Test2 Int Int deriving Show
$(derive[''Test2])

trans :: (Data FromJsonD a) => a -> Int
trans _ = 7