{-# LANGUAGE CPP, OverloadedStrings, PatternGuards, DefaultSignatures, FlexibleInstances #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#define PRAGMA_OVERLAPPING
#else
#define PRAGMA_OVERLAPPING {-# OVERLAPPING #-}
#endif

module Database.RethinkDB.Datum (
  parse, Parser, Result(..),
  Datum(..), ToDatum(..), FromDatum(..), fromDatum,
  LonLat(..), Array, Object, GeoLine(..), GeoPolygon(..),
  (.=), (.:), (.:?),
  encode, decode, eitherDecode,
  resultToMaybe, resultToEither,
  object
  ) where

import qualified Data.Aeson as J
import qualified Data.Aeson.Types as J
import Data.Aeson.Types (Parser, Result(..), FromJSON(..), parse, ToJSON(..), Value)
import Data.Aeson (fromJSON)
import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy as LB
import Data.Time
import Data.Time.Clock.POSIX
import qualified Data.Text as ST
import qualified Data.Text.Lazy as LT
import Data.Text.Encoding (encodeUtf8)
import qualified Data.HashMap.Strict as HM
import Data.Monoid
import Data.List
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.ByteString.Base64 as Base64
import Control.Applicative
import Data.Scientific
import Data.Int
import Data.Word
import qualified Data.ByteString.Char8 as Char8
import Control.Monad
import qualified Data.Map as Map
import Data.Ratio
import qualified Data.Set as Set

-- | A ReQL value
data Datum =
  Null |
  Bool Bool |
  String ST.Text |
  Number Double |
  Array Array |
  Object Object |
  Time ZonedTime |
  Point LonLat |
  Line GeoLine |
  Polygon GeoPolygon |
  Binary SB.ByteString

class FromDatum a where
  parseDatum :: Datum -> Parser a
  default parseDatum :: FromJSON a => Datum -> Parser a
  parseDatum = parseJSON . toJSON

errorExpected :: Show d => String -> d -> J.Parser x
errorExpected t d = fail $ "Expected " ++ t ++ " but found " ++ take 100 (show d)

instance FromDatum a => FromDatum [a] where
  parseDatum (Array v) = mapM parseDatum $ V.toList v
  parseDatum d = errorExpected "Array" d

instance FromDatum Datum where
  parseDatum = return

instance FromDatum () where
  parseDatum (Array a) | V.null a = return ()
  parseDatum d = errorExpected "Array" d

instance (FromDatum a, FromDatum b) => FromDatum (a, b) where
  parseDatum (Array xs) | [a,b] <- V.toList xs =
    (,) <$> parseDatum a <*> parseDatum b
  parseDatum d = errorExpected "Array" d

instance (FromDatum a, FromDatum b, FromDatum c) => FromDatum (a, b, c) where
  parseDatum (Array xs) | [a,b,c] <- V.toList xs =
    (,,) <$> parseDatum a <*> parseDatum b <*> parseDatum c
  parseDatum d = errorExpected "Array" d

instance (FromDatum a, FromDatum b, FromDatum c, FromDatum d) => FromDatum (a, b, c, d) where
  parseDatum (Array xs) | [a,b,c,d] <- V.toList xs =
    (,,,) <$> parseDatum a <*> parseDatum b <*> parseDatum c <*> parseDatum d
  parseDatum d = errorExpected "Array" d

instance (FromDatum a, FromDatum b, FromDatum c, FromDatum d, FromDatum e) => FromDatum (a, b, c, d, e) where
  parseDatum (Array xs) | [a,b,c,d,e] <- V.toList xs =
    (,,,,) <$> parseDatum a <*> parseDatum b <*> parseDatum c <*> parseDatum d <*> parseDatum e
  parseDatum d = errorExpected "Array" d

instance (FromDatum a, FromDatum b) => FromDatum (Either a b) where
  parseDatum (Object o) =
    Left <$> o .: "Left"
    <|> Right <$> o .: "Right"
  parseDatum d = errorExpected "Object" d

instance FromDatum SB.ByteString where
  parseDatum (Binary b) = return b
  parseDatum d = errorExpected "Binary" d

instance FromDatum LB.ByteString where
  parseDatum (Binary b) = return $ LB.fromStrict b
  parseDatum d = errorExpected "Binary" d

instance FromDatum a => FromDatum (HM.HashMap ST.Text a) where
  parseDatum (Object o) =
    fmap HM.fromList . sequence . map (\(k,v) -> (,) k <$> parseDatum v) $ HM.toList o
  parseDatum d = errorExpected "Object" d

instance FromDatum a => FromDatum (HM.HashMap [Char] a) where
  parseDatum (Object o) =
    fmap HM.fromList . sequence . map (\(k,v) -> (,) (ST.unpack k) <$> parseDatum v) $ HM.toList o
  parseDatum d = errorExpected "Object" d

instance FromDatum a => FromDatum (Map.Map ST.Text a) where
  parseDatum (Object o) =
    fmap Map.fromList . mapM (\(k,v) -> (,) k <$> parseDatum v) $ HM.toList o
  parseDatum d = errorExpected "Object" d

instance FromDatum a => FromDatum (Map.Map [Char] a) where
  parseDatum (Object o) =
    fmap Map.fromList . mapM (\(k,v) -> (,) (ST.unpack k) <$> parseDatum v) $ HM.toList o
  parseDatum d = errorExpected "Object" d

instance FromDatum a => FromDatum (Maybe a) where
  parseDatum Null = return Nothing
  parseDatum d = Just <$> parseDatum d

instance (Ord a, FromDatum a) => FromDatum (Set.Set a) where
  parseDatum (Array a) = fmap Set.fromList . mapM parseDatum $ V.toList a
  parseDatum d = errorExpected "Array" d

instance FromDatum ZonedTime where
  parseDatum (Time t) = return t
  parseDatum d = errorExpected "Time" d

instance FromDatum UTCTime where
  parseDatum (Time t) = return $ zonedTimeToUTC t
  parseDatum d = errorExpected "Time" d

instance FromDatum a => FromDatum (Vector a) where
  parseDatum (Array v) = fmap V.fromList . mapM parseDatum $ V.toList v
  parseDatum d = errorExpected "Array" d

instance FromDatum GeoLine where
  parseDatum (Line l) = return l
  parseDatum d = errorExpected "Line" d

instance FromDatum GeoPolygon where
  parseDatum (Polygon p) = return p
  parseDatum d = errorExpected "Polygon" d

instance FromDatum LonLat where
  parseDatum (Point l) = return l
  parseDatum d = errorExpected "Point" d

instance FromDatum Float
instance PRAGMA_OVERLAPPING FromDatum String
instance FromDatum Int
instance FromDatum Int8
instance FromDatum Int16
instance FromDatum Int32
instance FromDatum Int64
instance FromDatum Word
instance FromDatum Word8
instance FromDatum Word16
instance FromDatum Word32
instance FromDatum Word64
instance FromDatum Double
instance FromDatum Bool
instance FromDatum J.Value
instance FromDatum Char
instance FromDatum Integer
instance FromDatum LT.Text
instance FromDatum ST.Text
instance FromDatum (Ratio Integer)

type Array = Vector Datum
type Object = HM.HashMap ST.Text Datum
newtype GeoLine = GeoLine { geoLinePoints :: Vector LonLat }
            deriving (Eq, Ord)
newtype GeoPolygon = GeoPolygon { geoPolygonLines :: Vector (Vector LonLat) }
            deriving (Eq, Ord)

data LonLat = LonLat { longitude, latitude :: Double }
            deriving (Eq, Ord)

instance Eq Datum where
  Null == Null = True
  Bool a == Bool b = a == b
  String a == String b = a == b
  Number a == Number b = a == b
  Array a == Array b = a == b
  Object a == Object b = a == b
  Time a == Time b = zonedTimeToUTC a == zonedTimeToUTC b
  Point a == Point b = a == b
  Line a == Line b = a == b
  Polygon a == Polygon b = a == b
  Binary a == Binary b = a == b
  _ == _ = False

instance Show LonLat where
  show (LonLat lon lat) = "LonLat " ++ showDouble lon ++ " " ++ showDouble lat

instance Show Datum where
  show Null = "null"
  show (Bool True) = "true"
  show (Bool False) = "false"
  show (Number d) = showDouble d
  show (String t) = show t
  show (Array v) = "[" ++ intercalate "," (map show $ V.toList v) ++ "]"
  show (Object o) = "{" ++ intercalate "," (map (\(k,v) -> show k ++ ":" ++ show v) $ HM.toList o) ++ "}"
  show (Time t) = "Time<" ++ show t ++ ">"
  show (Point p) = "Point<" ++ showLonLat p ++ ">"
  show (Line l) = "Line<[" ++ intercalate "],[" (map showLonLat $ V.toList $ geoLinePoints l) ++ "]>"
  show (Polygon p) = "Polygon<[" ++ intercalate "],[" (map (\x -> "[" ++ intercalate "],[" (map showLonLat $ V.toList x) ++ "]") (V.toList $ geoPolygonLines p)) ++ "]>"
  show (Binary b) = "Binary<" ++ show b ++ ">"

showLonLat :: LonLat -> String
showLonLat (LonLat a b) = showDouble a ++ "," ++ showDouble b

showDouble :: Double -> String
showDouble d = let s = show d in if ".0" `isSuffixOf` s then init (init s) else s

fromDatum :: FromDatum a => Datum -> Result a
fromDatum = parse parseDatum

class ToDatum a where
  toDatum :: a -> Datum
  default toDatum :: ToJSON a => a -> Datum
  toDatum = toJSONDatum

instance ToDatum a => ToDatum [a] where
  toDatum = Array . V.fromList . map toDatum

instance ToDatum a => ToDatum (V.Vector a) where
  toDatum = Array . V.map toDatum

instance ToDatum Datum where
  toDatum = id

instance ToDatum () where
  toDatum _ = Array $ V.empty

instance (ToDatum a, ToDatum b) => ToDatum (a, b) where
  toDatum (a, b) = Array $ V.fromList [toDatum a, toDatum b]

instance (ToDatum a, ToDatum b, ToDatum c) => ToDatum (a, b, c) where
  toDatum (a, b, c) = Array $ V.fromList [toDatum a, toDatum b, toDatum c]

instance (ToDatum a, ToDatum b, ToDatum c, ToDatum d) => ToDatum (a, b, c, d) where
  toDatum (a, b, c, d) = Array $ V.fromList [toDatum a, toDatum b, toDatum c, toDatum d]

instance (ToDatum a, ToDatum b, ToDatum c, ToDatum d, ToDatum e) => ToDatum (a, b, c, d, e) where
  toDatum (a, b, c, d, e) = Array $ V.fromList [toDatum a, toDatum b, toDatum c, toDatum d, toDatum e]

instance ToDatum a => ToDatum (HM.HashMap ST.Text a) where
  toDatum = Object . HM.map toDatum

instance ToDatum a => ToDatum (HM.HashMap [Char] a) where
  toDatum = Object . HM.fromList . map (\(k, v) -> (ST.pack k, toDatum v)) . HM.toList

instance ToDatum a => ToDatum (Map.Map ST.Text a) where
  toDatum = Object . HM.fromList . Map.toList . Map.map toDatum

instance ToDatum a => ToDatum (Map.Map [Char] a) where
  toDatum = Object . HM.fromList . map (\(k, v) -> (ST.pack k, toDatum v)) . Map.toList

instance ToDatum ZonedTime where
  toDatum = Time

instance ToDatum UTCTime where
  toDatum = Time . utcToZonedTime utc

instance (ToDatum a, ToDatum b) => ToDatum (Either a b) where
  toDatum (Left a) = Object $ HM.fromList [("Left", toDatum a)]
  toDatum (Right b) = Object $ HM.fromList [("Right", toDatum b)]

instance ToDatum LB.ByteString where
  toDatum = Binary . LB.toStrict

instance ToDatum SB.ByteString where
  toDatum = Binary

instance ToDatum a => ToDatum (Maybe a) where
  toDatum Nothing = Null
  toDatum (Just a) = toDatum a

instance ToDatum a => ToDatum (Set.Set a) where
  toDatum = Array . V.fromList . map toDatum . Set.toList

instance ToDatum (Ratio Integer) where
  toDatum a = toDatum (toDouble a)
    where toDouble :: Rational -> Double
          toDouble = fromRational

instance ToDatum LonLat where
  toDatum l = Point l

instance ToDatum Value
instance ToDatum Int
instance ToDatum Int8
instance ToDatum Int16
instance ToDatum Int32
instance ToDatum Int64
instance ToDatum Word
instance ToDatum Word8
instance ToDatum Word16
instance ToDatum Word32
instance ToDatum Word64
instance ToDatum Char
instance PRAGMA_OVERLAPPING ToDatum [Char]
instance ToDatum Integer
instance ToDatum ST.Text
instance ToDatum LT.Text
instance ToDatum Bool
instance ToDatum Double
instance ToDatum Float

toJSONDatum :: ToJSON a => a -> Datum
toJSONDatum a = case toJSON a of
  J.Object o ->
    let asObject = Object $ HM.map toJSONDatum o
        ptype = HM.lookup "$reql_type$" o
    in case ptype of
      Just "GEOMETRY" |
        Just t <- HM.lookup "type" o,
        Just c <- HM.lookup "coordinates" o ->
          case t of
            "Point" | Success [lon, lat] <- fromJSON c -> Point (LonLat lon lat)
            "LineString" | Success l <- V.mapM toLonLat =<< fromJSON c -> Line (GeoLine l)
            "Polygon" | Success p <- V.mapM (V.mapM toLonLat) =<< fromJSON c -> Polygon (GeoPolygon p)
            _ -> asObject
      Just "TIME" |
        Just (J.Number ts) <- HM.lookup "epoch_time" o,
        Just (J.String tz) <- HM.lookup "timezone" o,
        Just tz' <- parseTimeZone (ST.unpack tz) ->
          Time $ utcToZonedTime tz' (posixSecondsToUTCTime . fromRational . toRational $ ts)
      Just "BINARY" |
        Just (J.String b64) <- HM.lookup "data" o,
        Right dat <- Base64.decode (encodeUtf8 b64) ->
         Binary dat
      _ -> asObject
  J.Null -> Null
  J.Bool b -> Bool b
  J.Number s -> Number (toRealFloat s)
  J.String t -> String t
  J.Array v -> Array (fmap toJSONDatum v)
  where
    toLonLat [lon, lat] = J.Success $ LonLat lon lat
    toLonLat _ = J.Error "expected a pair"
instance J.FromJSON Datum where
  parseJSON = return . toJSONDatum

instance ToJSON Datum where
  toJSON Null = J.Null
  toJSON (Bool b) = J.Bool b
  toJSON (Number d) = J.Number $ realToFrac d
  toJSON (String t) = J.String t
  toJSON (Array v) = J.Array $ V.map toJSON v
  toJSON (Object o) = J.Object $ HM.map toJSON o
  toJSON (Time ts@(ZonedTime _ tz)) = J.object [
    "$reql_type$" J..= ("TIME" :: ST.Text),
    "epoch_time" J..= (realToFrac (utcTimeToPOSIXSeconds (zonedTimeToUTC ts)) :: Double),
    "timezone" J..= timeZoneOffsetString tz]
  toJSON (Point p) = J.object [
    "$reql_type$" J..= ("GEOMETRY" :: ST.Text),
    "type" J..= ("Point" :: ST.Text),
    "coordinates" J..= pointToPair p]
  toJSON (Line l) = J.object [
    "$reql_type$" J..= ("GEOMETRY" :: ST.Text),
    "type" J..= ("LineString" :: ST.Text),
    "coordinates" J..= V.map pointToPair (geoLinePoints l)]
  toJSON (Polygon p) = J.object [
    "$reql_type$" J..= ("GEOMETRY" :: ST.Text),
    "type" J..= ("Polygon" :: ST.Text),
    "coordinates" J..= V.map (V.map pointToPair) (geoPolygonLines p)]
  toJSON (Binary b) = J.object [
    "$reql_type$" J..= ("BINARY" :: ST.Text),
    "data" J..= Char8.unpack (Base64.encode b)]

pointToPair :: LonLat -> (Double, Double)
pointToPair (LonLat lon lat) = (lon, lat)

parseTimeZone :: String -> Maybe TimeZone
parseTimeZone "Z" = Just utc
parseTimeZone tz = minutesToTimeZone <$> case tz of
  ('-':tz') -> negate <$> go tz'
  ('+':tz') -> go tz'
  _ -> go tz
  where
    go tz' =
        let (h, _:m) = break (==':') tz' in
        case (reads h, reads m) of
            ([(hh, "")], [(mm, "")]) -> Just $ hh * 60 + mm
            _ -> Nothing

-- ReQL datums are compared alphabetically by type name. Objects are
-- compared field by field in alphabetical order.
instance Ord Datum where
  compare (Object a) (Object b) =
        compare (sort $ HM.keys a) (sort $ HM.keys b) <>
        mconcat (map (\k -> (a HM.! k) `compare` (b HM.! k) ) (sort $ HM.keys a))
  compare (Array a) (Array b) = compare a b
  compare (String a) (String b) = compare a b
  compare (Number a) (Number b) = compare a b
  compare (Bool a) (Bool b) = compare a b
  compare Null Null = EQ
  compare (Time a) (Time b) = zonedTimeToUTC a `compare` zonedTimeToUTC b
  compare (Point a) (Point b) = compare a b
  compare (Line a) (Line b) = compare a b
  compare (Polygon a) (Polygon b) = compare a b
  compare (Binary a) (Binary b) = compare a b
  compare Array{} _ = LT
  compare _ Array{} = GT
  compare Bool{} _ = LT
  compare _ Bool{} = GT
  compare Null _ = LT
  compare _ Null = GT
  compare Number{} _ = LT
  compare _ Number{} = GT
  compare Object{} _ = LT
  compare _ Object{} = GT
  compare Binary{} _ = LT
  compare _ Binary{} = GT
  compare Polygon{} _ = LT
  compare _ Polygon{} = GT
  compare Line{} _ = LT
  compare _ Line{} = GT
  compare Point{} _ = LT
  compare _ Point{} = GT
  compare Time{} _ = LT
  compare _ Time{} = GT

(.=) :: ToDatum a => ST.Text -> a -> (ST.Text, Datum)
k .= v = (k, toDatum v)

(.:) :: FromDatum a => HM.HashMap ST.Text Datum -> ST.Text -> Parser a
o .: k = maybe (fail $ "key " ++ show k ++ "not found") parseDatum $ HM.lookup k o

(.:?) :: FromDatum a => HM.HashMap ST.Text Datum -> ST.Text -> Parser (Maybe a)
o .:? k = maybe (return Nothing) (fmap Just . parseDatum) $ HM.lookup k o

encode :: ToDatum a => a -> LB.ByteString
encode = J.encode . toDatum

decode :: FromDatum a => LB.ByteString -> Maybe a
decode = resultToMaybe . fromDatum <=< J.decode

eitherDecode :: FromDatum a => LB.ByteString -> Either String a
eitherDecode b = resultToEither . fromDatum =<< J.eitherDecode b

resultToMaybe :: Result a -> Maybe a
resultToMaybe (Success a) = Just a
resultToMaybe (Error _) = Nothing

resultToEither :: Result a -> Either String a
resultToEither (Success a) = Right a
resultToEither (Error s) = Left s

object :: [(ST.Text, Datum)] -> Datum
object = Object . HM.fromList