{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
{-| This module exports several classes and combinators that operated on
  'Structured' types. Specifically, we provide the structured versions
  of @mongoDB@''s combinators, including structured query creation.
-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.MongoDB.Structured.Query (
                                          -- * Insert
                                           insert, insert_
                                         , insertMany, insertMany_
                                         , insertAll, insertAll_
                                         -- * Update
                                         , save
                                         -- * Delete
                                         , delete, deleteOne
                                         -- * Order
                                         , asc
                                         , desc
                                         -- * Query
                                         , StructuredQuery
                                         , limit
                                         , skip
                                         , sort
                                         , find
                                         , findOne
                                         , fetch
                                         , count
                                         -- * Structured selections/queries
                                         , StructuredSelection
                                         , StructuredSelect(select)
                                         , Selectable(..)
                                         , (.!)
                                         , QueryExp
                                         , (.*)
                                         , (.==), (./=), (.<), (.<=), (.>), (.>=)
                                         , (.&&), (.||), not_
                                         -- * Cursor
                                         , StructuredCursor
                                         , closeCursor, isCursorClosed
                                         , nextBatch, next, nextN, rest
                                         -- * Rexports
                                         , module Database.MongoDB.Query
                                         , Value
                                         ) where

import qualified Database.MongoDB.Query as M
import Database.MongoDB.Query (Action
                              , access
                              , Failure(..)
                              , ErrorCode
                              , AccessMode(..)
                              , GetLastError
                              , master
                              , slaveOk
                              , accessMode
                              , MonadDB(..)
                              , Database
                              , allDatabases
                              , useDb
                              , thisDatabase
                              , Username
                              , Password
                              , auth)
import Database.MongoDB.Structured.Types
import Database.MongoDB.Internal.Util
import Data.Bson
import Data.Maybe (fromJust)
import Data.List (sortBy, groupBy)
import Data.Functor
import Data.Word
import Data.CompactString.UTF8 (intercalate)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Control.Monad.Base


--
-- Insert
--

-- | Inserts document to its corresponding collection and return
-- the \"_id\" value.
insert :: (MonadIO' m, Structured a) => a -> Action m Value
insert x = M.insert (collection x) (toBSON x)

-- | Same as 'insert' but discarding result.
insert_ :: (MonadIO' m, Structured a) => a -> Action m ()
insert_ x = insert x >> return ()

-- | Inserts documents to their corresponding collection and return
-- their \"_id\" values.
insertMany :: (MonadIO' m, Structured a) => [a] -> Action m [Value]
insertMany = insertManyOrAll (M.insertMany)

-- | Same as 'insertMany' but discarding result.
insertMany_ :: (MonadIO' m, Structured a) => [a] -> Action m ()
insertMany_ ss = insertMany ss >> return ()

-- | Inserts documents to their corresponding collection and return
-- their \"_id\" values. Unlike 'insertMany', this function keeps
-- inserting remaining documents even if an error occurs.
insertAll :: (MonadIO' m, Structured a) => [a] -> Action m [Value]
insertAll = insertManyOrAll (M.insertAll)

-- | Same as 'insertAll' but discarding result.
insertAll_ :: (MonadIO' m, Structured a) => [a] -> Action m ()
insertAll_ ss = insertAll ss >> return ()

-- | Helper function that carries out the hard work for 'insertMany'
-- and 'insertAll'.
insertManyOrAll :: (MonadIO' m, Structured a) =>
   (M.Collection -> [Document] -> Action m [Value]) -> [a] -> Action m [Value]
insertManyOrAll insertFunc ss = do
  let docs  = map (\x -> (collection x, toBSON x)) ss
      gdocs = (groupBy (\(a,_) (b,_) -> a == b))
              . (sortBy (\(a,_) (b,_) -> compare a b)) $ docs
  concat <$> (forM gdocs $ \ds ->
                if (null ds)
                  then return []
                  else insertFunc (fst . head $ ds) (map snd ds)
             )

--
-- Update
--

-- | Save document to collection. If the 'SObjId' field is set then
-- the document is updated, otherwise we perform an insert.
save :: (MonadIO' m, Structured a) => a -> Action m ()
save x = M.save (collection x) (toBSON x)


--
-- Delete
--

-- | Delete all documents that match the selection/query.
delete :: MonadIO m => StructuredSelection -> Action m ()
delete = M.delete . unStructuredSelection 

-- | Delete the first documents that match the selection/query.
deleteOne :: MonadIO m => StructuredSelection -> Action m ()
deleteOne = M.deleteOne . unStructuredSelection 


--
-- Query
--

-- | Find documents satisfying query
find :: (Functor m, MonadIO m, MonadBaseControl IO m)
     => StructuredQuery -> Action m StructuredCursor
find q = StructuredCursor <$> (M.find . unStructuredQuery $ q)

-- | Find documents satisfying query
findOne :: (MonadIO m, Structured a)
     => StructuredQuery -> Action m (Maybe a)
findOne q = do 
  res <- M.findOne . unStructuredQuery $ q
  return $ res >>= fromBSON

-- | Same as 'findOne' but throws 'DocNotFound' if none match. Error
-- is thrown if the document cannot e transformed.
fetch :: (MonadIO m, Functor m, Structured a)
     => StructuredQuery -> Action m a
fetch q = (fromJust . fromBSON) <$> (M.fetch . unStructuredQuery $ q)

-- | Count number of documents satisfying query.
count :: (MonadIO' m) => StructuredQuery -> Action m Int
count = M.count . unStructuredQuery


--
--
--

-- | Wrapper for @mongoDB@'s @Cursor@.
newtype StructuredCursor = StructuredCursor { unStructuredCursor :: M.Cursor }

-- | Return next batch of structured documents.
nextBatch :: (Structured a, Functor m, MonadIO m, MonadBaseControl IO m)
          => StructuredCursor -> Action m [Maybe a]
nextBatch c = (map fromBSON) <$> M.nextBatch (unStructuredCursor c)

-- | Return next structured document. If failed return 'Left',
-- otherwise 'Right' of the deserialized result.
next :: (Structured a, MonadIO m, MonadBaseControl IO m)
     => StructuredCursor -> Action m (Either () (Maybe a))
next c = do
    res <- M.next (unStructuredCursor c)
    case res of
      Nothing -> return (Left ())
      Just r  -> return (Right $ fromBSON r)

-- | Return up to next @N@ documents.
nextN :: (Structured a, Functor m, MonadIO m, MonadBaseControl IO m)
      => Int -> StructuredCursor -> Action m [Maybe a]
nextN n c = (map fromBSON) <$> M.nextN n (unStructuredCursor c)


-- | Return the remaining documents in query result.
rest :: (Structured a, Functor m, MonadIO m, MonadBaseControl IO m) 
     => StructuredCursor -> Action m [Maybe a]
rest c = (map fromBSON) <$> M.rest (unStructuredCursor c)

-- | Close the cursor.
closeCursor :: (MonadIO m, MonadBaseControl IO m) => StructuredCursor -> Action m ()
closeCursor = M.closeCursor . unStructuredCursor

-- | Check if the cursor is closed.
isCursorClosed :: (MonadIO m, MonadBase IO m) => StructuredCursor -> Action m Bool
isCursorClosed = M.isCursorClosed . unStructuredCursor



--
-- Structured selections/queries
--

-- | Wrapper for @mongoDB@'s @Selection@ type.
newtype StructuredSelection =
  StructuredSelection { unStructuredSelection :: M.Selection }
  deriving(Eq, Show)

-- | Wrapper for @mongoDB@'s @Query@ type.
data StructuredQuery = StructuredQuery
                        { selection :: StructuredSelection
                        -- ^ Actual query.
                        , skip      :: Word32 
                        -- ^ Number of matching objects to skip
                        -- (default: 0).
                        , limit     :: Word32
                        -- ^ Maximum number of objects to return
                        -- (default: 0, no limit).
                        , sort      :: [OrderExp]
                        -- ^ Sortresult by this order.
                        }
  deriving(Eq, Show)


-- | Analog to @mongoDB@'s @Select@ class
class StructuredSelect aQorS where
  -- | Create a selection or query from an expression
  select :: Structured a => QueryExp a -> aQorS

instance StructuredSelect StructuredSelection where
  select = StructuredSelection . expToSelection

instance StructuredSelect StructuredQuery where
  select x = StructuredQuery (StructuredSelection $ expToSelection x)
                              0 0 ([])

unStructuredQuery :: StructuredQuery -> M.Query
unStructuredQuery sq = M.Query [] -- options
                               (unStructuredSelection $ selection sq)
                               [] -- project
                               (skip sq) -- skip
                               (limit sq) -- limit
                               (expToOrder $ sort sq) -- sort
                               False 0 []

-- | Class defining a selectable type. Type 'a' corresponds to the
-- record type, 'f' corresponds to the field or facet, and 't'
-- corresponds to the field/facet type.
class Val t => Selectable a f t | f -> a, f -> t where
  -- | Given facet, return the BSON field name
  s :: f -> t -> Label

-- | Nested fields (used for extracting the names of fields in a
-- nested record). 
data Nested f f' = Nested Label

-- | Combining two field names to create a 'Nested' type.
(.!) :: (Selectable r f t, Selectable t f' t') => f -> f' -> Nested f f'
(.!) f f' = Nested $ intercalate (u ".") [(s f undefined), (s f' undefined)]

instance (Selectable r f t, Selectable t f' t') =>
          Selectable r (Nested f f') t' where
  s (Nested l) _ = l

-- | A query expression.
data QueryExp a = StarExp
                | EqExp   !Label   !Value
                | LBinExp !UString !Label !Value
                | AndExp  (QueryExp a) (QueryExp a) 
                | OrExp   (QueryExp a) (QueryExp a) 
                | NotExp  (QueryExp a)
                deriving (Eq, Show)

infix   9 .! 
infix   4 .==, ./=, .<, .<=, .>, .>=
infixr  3 .&&
infixr  2 .||

-- | Combinator for @==@
(.*) :: (Structured a) => QueryExp a
(.*) = StarExp

-- | Combinator for @==@
(.==) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
(.==) f v = EqExp  (s f v) (val v)

-- | Combinator for @$ne@
(./=) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
(./=) f v = LBinExp (u "$ne") (s f v) (val v)

-- | Combinator for @<@
(.< ) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
(.< ) f v = LBinExp (u "$lt") (s f v) (val v)

-- | Combinator for @<=@
(.<=) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
(.<=) f v = LBinExp (u "$lte") (s f v) (val v)

-- | Combinator for @>@
(.> ) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
(.> ) f v = LBinExp (u "$gt") (s f v) (val v)

-- | Combinator for @>=@
(.>=) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
(.>=) f v = LBinExp (u "$gte") (s f v) (val v)

-- | Combinator for @$and@
(.&&) :: QueryExp a -> QueryExp a -> QueryExp a
(.&&) = AndExp

-- | Combinator for @$or@
(.||) :: QueryExp a -> QueryExp a -> QueryExp a
(.||) = OrExp

-- | Combinator for @$not@
not_ :: QueryExp a -> QueryExp a
not_ = NotExp

-- | Convert a query expression to a 'Selector'.
expToSelector :: Structured a => QueryExp a -> M.Selector
expToSelector (StarExp)        = [ ]
expToSelector (EqExp l v)      = [ l := v ]
expToSelector (LBinExp op l v) = [ l =: [ op := v ]]
expToSelector (AndExp e1 e2)   = [ (u "$and") =: [expToSelector e1
                                                 , expToSelector e2] ]
expToSelector (OrExp e1 e2)    = [ (u "$or") =: [expToSelector e1
                                                , expToSelector e2] ]
expToSelector (NotExp e)       = [ (u "$not") =: expToSelector e]

-- | Convert query expression to 'Selection'.
expToSelection :: Structured a => QueryExp a -> M.Selection
expToSelection e = M.Select { M.selector = (expToSelector e)
                            , M.coll = (collection . c $ e) }
  where c :: Structured a => QueryExp a -> a
        c _ = undefined

-- | An ordering expression
data OrderExp = Desc Label
              | Asc Label
  deriving(Eq, Show)

-- | Sort by field, ascending
asc :: Selectable a f t => f -> OrderExp
asc f = Asc (s f undefined)

-- | Sort by field, descending
desc :: Selectable a f t => f -> OrderExp
desc f = Desc (s f undefined)

-- | Convert a list of @OrderExp@ to a @mongoDB@ @Order@
expToOrder :: [OrderExp] -> M.Order
expToOrder exps = map _expToLabel exps
  where _expToLabel (Desc fieldName) = fieldName := val (-1 :: Int)
        _expToLabel (Asc fieldName) = fieldName := val (1 :: Int)