{-# LANGUAGE ExistentialQuantification, RecordWildCards,
             ScopedTypeVariables, FlexibleInstances,
             OverloadedStrings, PatternGuards, GADTs,
             EmptyDataDecls, DefaultSignatures, CPP #-}

#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#define PRAGMA_OVERLAPPING
#else
#define PRAGMA_OVERLAPPING {-# OVERLAPPING #-}
#endif

-- | Building RQL queries in Haskell
module Database.RethinkDB.ReQL (
  ReQL(..),
  op, op',
  Term(..),
  TermAttribute(..),
  buildQuery,
  Backtrace, convertBacktrace, Frame(..),
  Expr(..),
  QuerySettings(..),
  newVarId,
  str,
  num,
  Attribute(..),
  Static, Dynamic, OptArg,
  OptArgs(..),
  cons,
  baseArray,
  withQuerySettings,
  reqlToDatum,
  Bound(..),
  closedOrOpen,
  datumTerm,
  empty,
  WireQuery(..),
  WireBacktrace(..),
  note,
  (?:=),
  Arr(arr),
  minval,
  maxval
  ) where

import qualified Data.Aeson as J
#if MIN_VERSION_aeson(1,0,0)
import qualified Data.Aeson.Text as J
#else
import qualified Data.Aeson.Encode as J
#endif
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LT
import Data.Aeson (Value)
import qualified Data.Vector as V
import qualified Data.HashMap.Lazy as M
import Data.Maybe (fromMaybe, catMaybes)
import Data.String (IsString(..))
import Data.List (intercalate)
import Control.Monad.State (State, get, put, runState)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import Data.Default (Default, def)
import qualified Data.Text as T
import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy as LB
import Data.Foldable (toList)
import Data.Time
import Control.Monad.Fix
import Data.Int
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.Char
import Data.Ratio
import Data.Word
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as Map
import qualified Data.Set as Set

import {-# SOURCE #-} Database.RethinkDB.Functions as R
import Database.RethinkDB.Wire
import Database.RethinkDB.Wire.Query
import qualified Database.RethinkDB.Wire.Term as Term
import Database.RethinkDB.Wire.Term hiding (JSON)
import Database.RethinkDB.Types
import Database.RethinkDB.Datum

-- $setup
--
-- Get the doctests ready
--
-- >>> import qualified Database.RethinkDB as R
-- >>> import Database.RethinkDB.NoClash
-- >>> h' <- connect "localhost" 28015 def
-- >>> let h = use "doctests" h'

-- | A ReQL Term
data ReQL = ReQL { runReQL :: State QuerySettings Term }

-- | Internal representation of a ReQL Term
data Term = Term {
  termType :: TermType,
  termArgs :: [Term],
  termOptArgs :: [TermAttribute]
  } | Datum {
  termDatum :: Datum
  } | Note {
  termNote :: String,
  termTerm :: Term
  } deriving Eq

-- | A term ready to be sent over the network
newtype WireTerm = WireTerm { termJSON :: Datum }

-- | State used to build a Term
data QuerySettings = QuerySettings {
  queryToken :: Int64,
  queryDefaultDatabase :: Database,
  queryVarIndex :: Int,
  queryReadMode :: Maybe String
  }

instance Default QuerySettings where
  def = QuerySettings 0 (Database "") 0 Nothing

withQuerySettings :: (QuerySettings -> ReQL) -> ReQL
withQuerySettings f = ReQL $ (runReQL . f) =<< get

-- | An operation that accepts optional arguments
class OptArgs a where
  -- | Extend an operation with optional arguments
  ex :: a -> [Attribute Static] -> a

instance OptArgs ReQL where
  ex (ReQL m) attrs = ReQL $ do
    e <- m
    case e of
      Datum _ -> return e
      Term t a oa -> Term t a . (oa ++) <$> baseAttributes attrs
      Note n t -> Note n <$> runReQL (ex (ReQL $ return t) attrs)

instance OptArgs b => OptArgs (a -> b) where
  ex f a = flip ex a . f

newVarId :: State QuerySettings Int
newVarId = do
  QuerySettings {..} <- get
  let n = queryVarIndex + 1
  put QuerySettings {queryVarIndex = n, ..}
  return $ n

instance Show Term where
  show (Datum dat) = show dat
  show (Note n term) = shortLines "" ["{- " ++ n ++ " -}", show term]
  show (Term MAKE_ARRAY x []) = "[" ++ (shortLines "," $ map show x) ++ "]"
  show (Term MAKE_OBJ [] x) = "{" ++ (shortLines "," $ map show x) ++ "}"
  show (Term MAKE_OBJ args []) = "{" ++ (shortLines "," $ map (\(a,b) -> show a ++ ":" ++ show b) $ pairs args) ++ "}"
     where pairs (a:b:xs) = (a,b) : pairs xs
           pairs _ = []
  show (Term VAR [Datum d] []) | Just x <- toInt d = varName x
  show (Term FUNC [args, body] []) | Just vars <- argList args =
    "(\\" ++ (shortLines " " $ map varName vars)
    ++ " -> " ++ show body ++ ")"
  show (Term BRACKET [o, k] []) = show o ++ "[" ++ show k ++ "]"
  show (Term FUNCALL (f : as) []) = "(" ++ show f ++ ")(" ++ shortLines "," (map show as) ++ ")"
  show (Term fun args oargs) =
    map toLower (show fun) ++ "(" ++
    shortLines "," (map show args ++ map show oargs) ++ ")"

shortLines :: String -> [String] -> String
shortLines sep args =
  if tooLong
  then "\n" ++ intercalate (sep ++ "\n") (map indent args)
  else intercalate (sep ++ " ") args
  where
    tooLong = any ('\n' `elem`) args || 80 < (length $ concat args)
    indent = (\x -> case x of [] -> []; _ -> init x) . unlines . map ("  "++) . lines

varName :: Int -> String
varName n = replicate (q+1) (chr $ ord 'a' + r)
  where (q, r) = quotRem n 26

-- | A list of terms
data ArgList = ArgList { baseArray :: State QuerySettings [Term] }

instance Monoid ArgList where
  mempty = ArgList $ return []
  mappend (ArgList a) (ArgList b) = ArgList $ (++) <$> a <*> b

-- | Build arrays of exprs
class Arr a where
  arr :: a -> ArgList

cons :: Expr e => e -> ArgList -> ArgList
cons x xs = ArgList $ do
  bt <- runReQL (expr x)
  xs' <- baseArray xs
  return $ bt : xs'

instance Arr () where
  arr () = ArgList $ return []

instance Expr a => Arr [a] where
  arr [] = ArgList $ return []
  arr (x:xs) = cons x (arr xs)

instance (Expr a, Expr b) => Arr (a, b) where
  arr (a,b) = cons a $ cons b $ arr ()

instance (Expr a, Expr b, Expr c) => Arr (a, b, c) where
  arr (a,b,c) = cons a $ cons b $ cons c $ arr ()

instance (Expr a, Expr b, Expr c, Expr d) => Arr (a, b, c, d) where
  arr (a,b,c,d) = cons a $ cons b $ cons c $ cons d $ arr ()

instance Arr ArgList where
  arr = id

infix 0 :=

-- | A key/value pair used for building objects
data Attribute a where
  (:=) :: Expr e => T.Text -> e -> Attribute a
  (::=) :: (Expr k, Expr v) => k -> v -> Attribute Dynamic
  NoAttribute :: Attribute a

(?:=) :: Expr e => T.Text -> Maybe e -> Attribute a
_ ?:= Nothing = NoAttribute
k ?:= (Just v) = k := v

type OptArg = Attribute Static

data Static
data Dynamic

instance Expr (Attribute a) where
  expr (k := v) = expr (k, v)
  expr (k ::= v) = expr (k, v)
  expr NoAttribute = expr Null
  exprList kvs = maybe (obj kvs) (op' MAKE_OBJ () . concat) $ mapM staticPair kvs
    where staticPair :: Attribute a -> Maybe [Attribute Static]
          staticPair (k := v) = Just [k := v]
          staticPair NoAttribute = Just []
          staticPair _ = Nothing
          obj :: [Attribute a] -> ReQL
          obj = op OBJECT . concatMap unpair
          unpair :: Attribute a -> [ReQL]
          unpair (k := v) = [expr k, expr v]
          unpair (k ::= v) = [expr k, expr v]
          unpair NoAttribute = []

data TermAttribute = TermAttribute T.Text Term deriving Eq

mapTermAttribute :: (Term -> Term) -> TermAttribute -> TermAttribute
mapTermAttribute f (TermAttribute k v) = TermAttribute k (f v)

instance Show TermAttribute where
  show (TermAttribute a b) = T.unpack a ++ ": " ++ show b

baseAttributes :: [Attribute Static] -> State QuerySettings [TermAttribute]
baseAttributes = sequence . concat . map toBase
  where
    toBase :: Attribute Static -> [State QuerySettings TermAttribute]
    toBase (k := v) = [TermAttribute k <$> runReQL (expr v)]
    toBase NoAttribute = []

-- | Build a term
op' :: Arr a => TermType -> a -> [Attribute Static] -> ReQL
op' t a b = ReQL $ do
  a' <- baseArray (arr a)
  b' <- baseAttributes b
  case (t, a', b') of
    -- Inline function calls if all arguments are variables
    (FUNCALL, (Term FUNC [argsFunTerm, fun] [] : argsCall), []) |
      Just varsFun <- argList argsFunTerm,
      length varsFun == length argsCall,
      Just varsCall <- varsOf argsCall ->
        return $ alphaRename (zip varsFun varsCall) fun
    _ -> return $ Term t a' b'

-- | Build a term with no optargs
op :: Arr a => TermType -> a -> ReQL
op t a = op' t a []

argList :: Term -> Maybe [Int]
argList (Datum d) | Just a <- toInts d = Just a
argList (Term MAKE_ARRAY a []) = mapM toInt =<< datums a
  where datums (Datum d:xs) = fmap (d:) $ datums xs; datums [] = Just []; datums _ = Nothing
argList _ = Nothing

toInts :: Datum -> Maybe [Int]
toInts (Array xs) = mapM toInt $ toList xs
toInts _ = Nothing

toInt :: Datum -> Maybe Int
toInt (Number n) = if denominator (toRational n) == 1 then Just (truncate n) else Nothing
toInt _ = Nothing

varsOf :: [Term] -> Maybe [Int]
varsOf = sequence . map varOf

varOf :: Term -> Maybe Int
varOf (Term VAR [Datum d] []) = toInt d
varOf _ = Nothing

alphaRename :: [(Int, Int)] -> Term -> Term
alphaRename assoc = fix $ \f x ->
  case varOf x of
    Just n
      | Just n' <- lookup n assoc ->
      Term VAR [Datum $ toDatum n'] []
      | otherwise -> x
    _ -> updateChildren x f

updateChildren :: Term -> (Term -> Term) -> Term
updateChildren (Note _ t) f = updateChildren t f
updateChildren d@Datum{} _ = d
updateChildren (Term t a o) f = Term t (map f a) (map (mapTermAttribute f) o)

datumTerm :: ToDatum a => a -> ReQL
datumTerm = ReQL . return . Datum . toDatum

-- | A shortcut for inserting strings into ReQL expressions
-- Useful when OverloadedStrings makes the type ambiguous
str :: String -> ReQL
str = datumTerm

-- | A shortcut for inserting numbers into ReQL expressions
num :: Double -> ReQL
num = expr

instance Num ReQL where
  fromInteger = datumTerm
  a + b = op ADD (a, b)
  a * b = op MUL (a, b)
  a - b = op SUB (a, b)
  negate a = op SUB (0 :: Double, a)
  abs n = op BRANCH (op Term.LT (n, 0 :: Double), negate n, n)
  signum n = op BRANCH (op Term.LT (n, 0 :: Double),
                        -1 :: Double,
                        op BRANCH (op Term.EQ (n, 0 :: Double), 0 :: Double, 1 :: Double))

instance IsString ReQL where
  fromString = datumTerm

-- | Convert other types into ReQL expressions
class Expr e where
  expr :: e -> ReQL
  default expr :: ToDatum e => e -> ReQL
  expr = datumTerm
  exprList :: [e] -> ReQL
  exprList = expr . arr

instance Expr ReQL where
  expr t = t

instance Expr Char where
  exprList = datumTerm

instance (Expr a, Expr b) => Expr (Either a b) where
  expr (Left a) = expr ["Left" := a]
  expr (Right b) = expr ["Right" := b]

instance PRAGMA_OVERLAPPING Expr a => Expr (HM.HashMap [Char] a) where
  expr = expr . map (\(k,v) -> T.pack k := v) . HM.toList

instance PRAGMA_OVERLAPPING Expr a => Expr (HM.HashMap T.Text a) where
  expr = expr . map (uncurry (:=)) . HM.toList

instance Expr a => Expr (Map.Map [Char] a) where
  expr = expr . map (\(k,v) -> T.pack k := v) . Map.toList

instance Expr a => Expr (Map.Map T.Text a) where
  expr = expr . map (uncurry (:=)) . Map.toList

instance Expr a => Expr (Maybe a) where
  expr Nothing = expr Null
  expr (Just a) = expr a

instance Expr a => Expr (Set.Set a) where
  expr = expr . Set.toList

instance Expr a => Expr (V.Vector a) where
  expr = expr . V.toList

instance Expr Value where
  expr v = op Term.JSON [encodeTextJSON v]

instance Expr Int
instance Expr Integer
instance Expr Bool
instance Expr Datum
instance Expr Double
instance Expr ()
instance Expr Float
instance Expr Int8
instance Expr Int16
instance Expr Int32
instance Expr Int64
instance Expr LT.Text
instance Expr T.Text
instance Expr LB.ByteString
instance Expr SB.ByteString
instance Expr Word
instance Expr Word8
instance Expr Word16
instance Expr Word32
instance Expr Word64
instance Expr (Ratio Integer)
instance Expr LonLat

instance (a ~ ReQL) => Expr (a -> ReQL) where
  expr f = ReQL $ do
    v <- newVarId
    runReQL $ op FUNC ([v], expr $ f (op VAR [v]))

instance (a ~ ReQL, b ~ ReQL) => Expr (a -> b -> ReQL) where
  expr f = ReQL $ do
    a <- newVarId
    b <- newVarId
    runReQL $ op FUNC ([a, b], expr $ f (op VAR [a]) (op VAR [b]))

instance (a ~ ReQL, b ~ ReQL, c ~ ReQL) => Expr (a -> b -> c -> ReQL) where
  expr f = ReQL $ do
    a <- newVarId
    b <- newVarId
    c <- newVarId
    runReQL $ op FUNC ([a, b, c], expr $ f (op VAR [a]) (op VAR [b]) (op VAR [c]))

instance (a ~ ReQL, b ~ ReQL, c ~ ReQL, d ~ ReQL) => Expr (a -> b -> c -> d -> ReQL) where
  expr f = ReQL $ do
    a <- newVarId
    b <- newVarId
    c <- newVarId
    d <- newVarId
    runReQL $ op FUNC ([a, b, c], expr $ f (op VAR [a]) (op VAR [b]) (op VAR [c]) (op VAR [d]))

instance (a ~ ReQL, b ~ ReQL, c ~ ReQL, d ~ ReQL, e ~ ReQL) => Expr (a -> b -> c -> d -> e -> ReQL) where
  expr f = ReQL $ do
    a <- newVarId
    b <- newVarId
    c <- newVarId
    d <- newVarId
    e <- newVarId
    runReQL $ op FUNC ([a, b, c], expr $ f (op VAR [a]) (op VAR [b]) (op VAR [c]) (op VAR [d]) (op VAR [e]))

instance Expr Table where
  expr (Table mdb name _) = withQuerySettings $ \QuerySettings {..} ->
    op' TABLE (fromMaybe queryDefaultDatabase mdb, name) $ catMaybes [
      fmap ("read_mode" :=) queryReadMode ]

instance Expr Database where
  expr (Database name) = op DB [name]

instance Expr a => Expr [a] where
  expr = exprList

instance Expr ArgList where
  expr a = op MAKE_ARRAY a

instance PRAGMA_OVERLAPPING (Expr k, Expr v) => Expr (M.HashMap k v) where
  expr m = expr $ map (uncurry (::=)) $ M.toList m


buildTerm :: Term -> WireTerm
buildTerm (Note _ t) = buildTerm t
buildTerm (Datum d)
  | complexDatum d = buildTerm $ Term Term.JSON [Datum $ toDatum $ encodeTextJSON $ J.toJSON d] []
  | otherwise = WireTerm $ d
buildTerm (Term type_ args oargs) =
  WireTerm $ toDatum (
    toWire type_,
    map (termJSON . buildTerm) args,
    buildAttributes oargs)

complexDatum :: Datum -> Bool
complexDatum Null = False
complexDatum Bool{} = False
complexDatum Number{} = False
complexDatum String{} = False
complexDatum _ = True

encodeTextJSON :: Value -> T.Text
encodeTextJSON = LT.toStrict . LT.toLazyText . J.encodeToTextBuilder

buildAttributes :: [TermAttribute] -> Datum
buildAttributes ts = toDatum $ M.fromList $ map toPair ts
 where toPair (TermAttribute a b) = (a, termJSON $ buildTerm b)

newtype WireQuery = WireQuery { queryJSON :: Datum }
                  deriving Show

buildQuery :: ReQL -> Int64 -> Database -> [(T.Text, Datum)] -> (WireQuery, Term)
buildQuery reql token db opts =
  (WireQuery $ toDatum (toWire START, termJSON pterm, object opts), bterm)
  where
    bterm = fst $ runState (runReQL reql) (def {queryToken = token,
                                                queryDefaultDatabase = db })
    pterm = buildTerm bterm

instance Show ReQL where
  show t = show . snd $ buildQuery t 0 (Database "") []

reqlToDatum :: ReQL -> Datum
reqlToDatum t = queryJSON $ fst $ buildQuery t 0 (Database "") []

type Backtrace = [Frame]

data Frame = FramePos Int | FrameOpt T.Text

instance Show Frame where
    show (FramePos n) = show n
    show (FrameOpt k) = show k

instance FromDatum Frame where
  parseDatum d@Number{} | Success i <- fromDatum d = return $ FramePos i
  parseDatum (String s) = return $ FrameOpt s
  parseDatum _ = mempty

newtype WireBacktrace = WireBacktrace { backtraceJSON :: Datum }

convertBacktrace :: WireBacktrace -> Backtrace
convertBacktrace (WireBacktrace b) =
  case fromDatum b of
    Success a -> a
    Error _ -> []

instance Expr UTCTime
instance Expr ZonedTime

instance Expr Term where
  expr = ReQL . return

-- | An upper or lower bound for between and during
data Bound a =
  Open { getBound :: a } -- ^ An inclusive bound
  | Closed { getBound :: a } -- ^ An exclusive bound
  | DefaultBound { getBound :: a }
  | MinVal
  | MaxVal

instance Expr a => Expr (Bound a) where
  expr (Open a) = expr a
  expr (Closed a) = expr a
  expr (DefaultBound a) = expr a
  expr MinVal = op MINVAL ()
  expr MaxVal = op MAXVAL ()

minval :: Bound a
minval = MinVal

maxval :: Bound a
maxval = MaxVal

instance Functor Bound where
  fmap f (Open a) = Open (f a)
  fmap f (Closed a) = Closed (f a)
  fmap f (DefaultBound a) = DefaultBound (f a)
  fmap _ MinVal = MinVal
  fmap _ MaxVal = MaxVal

closedOrOpen :: Bound a -> Maybe T.Text
closedOrOpen Open{} = Just "open"
closedOrOpen Closed{} = Just "closed"
closedOrOpen DefaultBound{} = Nothing
closedOrOpen MinVal = Nothing
closedOrOpen MaxVal = Nothing

boundOp :: (a -> a -> a) -> Bound a -> Bound a -> Bound a
boundOp f (Closed a) (Closed b) = Closed $ f a b
boundOp f (Closed a) (Open b) = Open $ f a b
boundOp f (Open a) (Closed b) = Open $ f a b
boundOp f (Open a) (Open b) = Open $ f a b
boundOp f (DefaultBound a) b = fmap (f a) b
boundOp f a (DefaultBound b) = fmap (flip f b) a
boundOp _ MaxVal a = a
boundOp _ MinVal a = a
boundOp _ a MaxVal = a
boundOp _ a MinVal = a

instance Num a => Num (Bound a) where
  (+) = boundOp (+)
  (-) = boundOp (-)
  (*) = boundOp (*)
  negate MinVal = MaxVal
  negate MaxVal = MaxVal
  negate a = fmap negate a
  abs MinVal = MaxVal
  abs a = fmap abs a
  signum MinVal = Open (-1)
  signum MaxVal = Open 1
  signum a = fmap signum a
  fromInteger = DefaultBound . fromInteger

-- | An empty object
empty :: ReQL
empty = op MAKE_OBJ ()

instance (Expr a, Expr b) => Expr (a, b) where
  expr (a, b) = expr [expr a, expr b]

instance (Expr a, Expr b, Expr c) => Expr (a, b, c) where
  expr (a, b, c) = expr [expr a, expr b, expr c]

instance (Expr a, Expr b, Expr c, Expr d) => Expr (a, b, c, d) where
  expr (a, b, c, d) = expr [expr a, expr b, expr c, expr d]

instance (Expr a, Expr b, Expr c, Expr d, Expr e) => Expr (a, b, c, d, e) where
  expr (a, b, c, d, e) = expr [expr a, expr b, expr c, expr d, expr e]

-- | Add a note a a ReQL Term
--
-- This note does not get sent to the server. It is used to annotate
-- backtraces and help debugging.
note :: String -> ReQL -> ReQL
note n (ReQL t) = ReQL $ return . Note n =<< t

instance Fractional ReQL where
  a / b = op DIV [a, b]
  recip a = op DIV [num 1, a]
  fromRational = expr

instance Floating ReQL where
  pi = js "Math.PI"
  exp x = js "(function(x){return Math.pow(Math.E,x)})" `apply` [x]
  sqrt x = js "Math.sqrt" `apply` [x]
  log x = js "Math.log" `apply` [x]
  (**) x y = js "Math.pow" `apply` [x, y]
  logBase x y = js "(function(x, y){return Math.log(x)/Math.log(y)})" `apply` [x, y]
  sin x = js "Math.sin" `apply` [x]
  tan x = js "Math.tan" `apply` [x]
  cos x = js "Math.cos" `apply` [x]
  asin x = js "Math.asin" `apply` [x]
  atan x = js "Math.atan" `apply` [x]
  acos x = js "Math.acos" `apply` [x]
  sinh = error "hyberbolic math is not supported"
  tanh = error "hyberbolic math is not supported"
  cosh = error "hyberbolic math is not supported"
  asinh = error "hyberbolic math is not supported"
  atanh = error "hyberbolic math is not supported"
  acosh = error "hyberbolic math is not supported"