EJson.hs

{-|

  Description : Internal definitions for EJson functionality

  Currently EJson functionality is built on top of the
  `Data.Aeson.Value` type.

  Functions are written to convert back and forth between
  `Data.EJson.EJsonValue` and `Data.Aeson.Value`.

  This has some negative impact on performance, but aids simplicity.

-}

{-# LANGUAGE     OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE     RankNTypes #-}
{-# LANGUAGE     TemplateHaskell #-}
{-# LANGUAGE     OverloadedStrings #-}
{-# LANGUAGE     TypeSynonymInstances #-}
{-# LANGUAGE     MultiParamTypeClasses #-}

module Data.EJson.EJson (

             EJsonValue(..)

             -- Conversion functions
             , value2EJson
             , ejson2value

             -- Smart Constructors
             , ejobject
             , ejarray
             , ejstring
             , ejnumber
             , ejbool
             , ejdate
             , ejbinary
             , ejuser
             , ejnull

             -- Prisms
             , _EJObject
             , _EJObjectKey
             , _EJObjectKeyString
             , _EJArray
             , _EJAraryIndex
             , _EJString
             , _EJNumber
             , _EJBool
             , _EJDate
             , _EJBinary
             , _EJUser
             , _EJNull
   ) where

import Data.Monoid
import Control.Monad
import Data.Aeson
import Data.Scientific
import Data.Text.Internal
import Data.Text.Encoding
import Data.ByteString hiding (putStr)
import Data.Vector
import Data.Maybe
import Data.HashMap.Strict
import Data.ByteString.Base64
import Data.String
import Control.Lens
import Control.Applicative

-- Time
import Data.Convertible
import System.Posix.Types (EpochTime)

-- Display purposes
import qualified Data.ByteString.Lazy.Char8 as BC8

data EJsonValue =
    EJObject !(Data.HashMap.Strict.HashMap Text EJsonValue)
  | EJArray  !(Data.Vector.Vector EJsonValue)
  | EJString !Text
  | EJNumber !Scientific
  | EJBool   !Bool
  | EJDate   !EpochTime
  | EJBinary !ByteString
  | EJUser   !Text !EJsonValue
  | EJNull
  deriving (Eq)

-- Instances follow!

-- Prismo time!
-- http://adventuretime.wikia.com/wiki/Prismo

makePrisms ''EJsonValue

_EJObjectKey :: Applicative f
             => Text
             -> (Maybe EJsonValue -> f (Maybe EJsonValue))
             -> EJsonValue
             -> f EJsonValue
_EJObjectKey k = _EJObject . at k

-- | A helpful prism that looks up values of type EJ{"foo" : "bar", ...}
--   with a Text key "foo" and returns Just "bar", or Nothing.
--   Used frequently for checking message types and ids.
_EJObjectKeyString :: Applicative f
                   => Text
                   -> (Text -> f Text)
                   -> EJsonValue
                   -> f EJsonValue
_EJObjectKeyString k = _EJObject . at k . _Just . _EJString

_EJAraryIndex :: Applicative f
              => Int
              -> (EJsonValue -> f EJsonValue)
              -> EJsonValue
              -> f EJsonValue
_EJAraryIndex i = _EJArray . ix i

instance Show EJsonValue
  where
  show = BC8.unpack . Data.Aeson.encode . ejson2value

instance IsString EJsonValue
  where
  fromString = EJString . Data.Convertible.convert

instance Monoid EJsonValue
  where
  mempty = EJNull

  EJObject o1 `mappend` EJObject o2 = EJObject $ mappend o1 o2
  EJArray  a1 `mappend` EJArray  a2 = EJArray  $ mappend a1 a2
  _           `mappend` _           = error "TODO: Haven't considered what to do here yet..."

-- TODO: Decide what to do about these error cases
instance Num EJsonValue
  where
  fromInteger = EJNumber . fromIntegral
  (EJNumber a) + (EJNumber b) = EJNumber (a + b)
  _            + _            = error "don't add non-numbers"
  (EJNumber a) * (EJNumber b) = EJNumber (a * b)
  _            * _            = error "don't multiply non-numbers"
  abs (EJNumber a)            = EJNumber (abs a)
  abs _                       = error "don't abolute non-numbers"
  signum (EJNumber a)         = EJNumber (signum a)
  signum _                    = error "don't signum non-numbers"
  negate (EJNumber a)         = EJNumber (negate a)
  negate _                    = error "don't negate non-numbers"

instance Convertible EpochTime Scientific
  where
  safeConvert e = Right (Data.Convertible.convert e)

ejson2value :: EJsonValue -> Value
ejson2value (EJObject h    ) = Object (Data.HashMap.Strict.map ejson2value h)
ejson2value (EJArray  v    ) = Array  (Data.Vector.map ejson2value v)
ejson2value (EJString t    ) = String t
ejson2value (EJNumber n    ) = Number n
ejson2value (EJBool   b    ) = Bool b
ejson2value (EJDate   t    ) = makeJsonDate t
ejson2value (EJBinary bs   ) = String $ decodeUtf8 $ Data.ByteString.Base64.encode bs
ejson2value (EJUser   t1 t2) = makeUser t1 t2
ejson2value (EJNull        ) = Null

value2EJson :: Value -> EJsonValue
value2EJson (Object o) = escapeObject o
value2EJson (Array  a) = EJArray $ Data.Vector.map value2EJson a
value2EJson (String s) = EJString s
value2EJson (Number n) = EJNumber n
value2EJson (Bool   b) = EJBool   b
value2EJson Null       = EJNull

-- Smart Constructors

{-# Inline ejobject #-}
ejobject :: [(Text, EJsonValue)] -> EJsonValue
ejobject = EJObject . Data.HashMap.Strict.fromList

{-# Inline ejarray #-}
ejarray :: [EJsonValue] -> EJsonValue
ejarray = EJArray . Data.Vector.fromList

{-# Inline ejstring #-}
ejstring :: Text -> EJsonValue
ejstring = EJString

{-# Inline ejnumber #-}
ejnumber :: Scientific -> EJsonValue
ejnumber = EJNumber

{-# Inline ejbool #-}
ejbool :: Bool -> EJsonValue
ejbool = EJBool

{-# Inline ejdate #-}
ejdate :: EpochTime -> EJsonValue
ejdate = EJDate

{-# Inline ejbinary #-}
ejbinary :: ByteString -> EJsonValue
ejbinary = EJBinary

{-# Inline ejuser #-}
ejuser :: Text -> EJsonValue -> EJsonValue
ejuser = EJUser

{-# Inline ejnull #-}
ejnull :: EJsonValue
ejnull = EJNull


-- Helpers

simpleKey :: Text -> Object -> Maybe Value
simpleKey k = Data.HashMap.Strict.lookup k

integer2date :: Integer -> EpochTime
integer2date = Data.Convertible.convert

parseDate :: Value -> Maybe EJsonValue
parseDate (Number n) = Just $ EJDate $ integer2date $ round n
parseDate _          = Nothing

parseBinary :: Value -> Maybe EJsonValue
parseBinary (String s) = Just (EJBinary (decodeLenient (encodeUtf8 s)))
parseBinary _          = Nothing

parseUser :: Value -> Value -> Maybe EJsonValue
parseUser (String k) v = Just $ EJUser k (value2EJson v)
parseUser _          _ = Nothing

parseEscaped :: Value -> Maybe EJsonValue
parseEscaped (Object o) = Just $ simpleObj o
parseEscaped          _ = Nothing

isDate        :: Int -> Object -> Maybe EJsonValue
isDate    1 o  = parseDate =<< simpleKey "$date" o
isDate    _ _  = Nothing
isBinary      :: Int -> Object -> Maybe EJsonValue
isBinary  1 o  = parseBinary =<< simpleKey "$binary" o
isBinary  _ _  = Nothing
isUser        :: Int -> Object -> Maybe EJsonValue
isUser    2 o  = do t <- simpleKey "$type"  o
                    v <- simpleKey "$value" o
                    parseUser t v
isUser    _ _  = Nothing
isEscaped     :: Int -> Object -> Maybe EJsonValue
isEscaped 1 o  = parseEscaped =<< simpleKey "$escape" o
isEscaped _ _  = Nothing

simpleObj :: HashMap Text Value -> EJsonValue
simpleObj o = EJObject $ Data.HashMap.Strict.map value2EJson o

escapeObject :: Object -> EJsonValue
escapeObject o = fromMaybe (simpleObj o)
               $ msum $ Prelude.map ($ o) [isDate l, isBinary l, isUser l, isEscaped l]
  where
  l = Data.HashMap.Strict.size o

makeJsonDate :: EpochTime -> Value
makeJsonDate t = Object
               $ Data.HashMap.Strict.fromList
               [ ("$date", Number $ Data.Convertible.convert t) ]

makeUser :: Text -> EJsonValue -> Value
makeUser t v = Object
           $ Data.HashMap.Strict.fromList
           [ ("$type" , String t)
           , ("$value", ejson2value v)]