module Database.CouchDB.ViewServer.Reduce
(
ReduceSignature
, ViewReduce
, module Database.CouchDB.ViewServer.Parse
, logMsg
, ReduceOutput
, ReduceFunc
, toReduceFunc
, reduceFuncInterpreter
, execReduceFunc
) where
import Data.Maybe
import Data.Typeable
import Data.Aeson (toJSON, ToJSON)
import Data.Aeson.Types (Value(..), Object, Parser, parseMaybe)
import Control.Applicative
import Control.Monad (Monad, MonadPlus)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Writer (WriterT, tell, runWriterT)
import qualified Language.Haskell.Interpreter as H
import Database.CouchDB.ViewServer.Internal
import Database.CouchDB.ViewServer.Parse
type ReduceOutput = (Value, [LogMessage])
newtype ViewReduce a = ViewReduce { runViewReduce :: WriterT [LogMessage] Parser a }
deriving(Monad, Functor, MonadPlus, Applicative, Alternative)
instance MonadParser ViewReduce where
liftParser = ViewReduce . lift
type ReduceSignature a = [Value] -> [Value] -> Bool -> ViewReduce a
newtype ReduceFunc = ReduceFunc { runReduceFunc :: ReduceSignature Value }
deriving (Typeable)
toReduceFunc :: ToJSON a => ReduceSignature a -> ReduceFunc
toReduceFunc f = ReduceFunc $ \k v r -> toJSON <$> f k v r
reduceFuncInterpreter :: [H.OptionVal H.Interpreter] -> [(H.ModuleName, Maybe String)] -> String -> H.Interpreter ReduceFunc
reduceFuncInterpreter opts mods source = do
H.set opts
H.setImportsQ $ mods ++ [("Database.CouchDB.ViewServer.Reduce", Nothing)]
H.interpret ("toReduceFunc " ++ H.parens source) (H.as :: ReduceFunc)
execReduceFunc :: ReduceFunc -> [Value] -> [Value] -> Bool -> ReduceOutput
execReduceFunc reduceFunc keys values rereduce = fromMaybe (Null, []) $ parseMaybe runWriterT (runViewReduce $ runReduceFunc reduceFunc keys values rereduce)
logMsg :: String -> ViewReduce ()
logMsg msg = ViewReduce $ tell [LogMessage msg]