module Database.CouchDB.ViewServer.Map
(
MapSignature
, ViewMap
, module Database.CouchDB.ViewServer.Parse
, emit
, emitM
, logMsg
, MapOutput(..)
, MapFunc(..)
, toMapFunc
, mapFuncInterpreter
, execMapFunc
, logs
, emits
) where
import Prelude hiding (log)
import Data.Maybe
import Data.Typeable
import Data.Aeson ((.:), (.:?), toJSON, FromJSON, ToJSON(..))
import Data.Aeson.Types (Value(..), Object, Parser, parseMaybe)
import qualified Data.Aeson.Types (parseJSON)
import Data.Text (Text, unpack)
import Control.Applicative
import Control.Monad (Monad, MonadPlus)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Writer (WriterT, tell, execWriterT)
import qualified Language.Haskell.Interpreter as H
import Database.CouchDB.ViewServer.Internal
import Database.CouchDB.ViewServer.Parse
data MapOutput =
Emit Value Value |
Log LogMessage
newtype ViewMap a = ViewMap { runViewMap :: WriterT [MapOutput] Parser a }
deriving(Monad, Functor, MonadPlus, Applicative, Alternative)
instance MonadParser ViewMap where
liftParser = ViewMap . lift
type MapSignature = Object -> ViewMap ()
newtype MapFunc = MapFunc { runMapFunc :: MapSignature }
deriving (Typeable)
toMapFunc = MapFunc
mapFuncInterpreter :: [H.OptionVal H.Interpreter] -> [(H.ModuleName, Maybe String)] -> String -> H.Interpreter MapFunc
mapFuncInterpreter opts mods source = do
H.set opts
H.setImportsQ $ mods ++ [("Database.CouchDB.ViewServer.Map", Nothing)]
H.interpret ("toMapFunc " ++ H.parens source) (H.as :: MapFunc)
execMapFunc :: MapFunc -> Object -> [MapOutput]
execMapFunc mapFunc doc = fromMaybe [] $ parseMaybe execWriterT (runViewMap $ runMapFunc mapFunc doc)
emits :: [MapOutput] -> [MapOutput]
emits = filter isEmit
isEmit (Emit _ _) = True
isEmit _ = False
logs :: [MapOutput] -> [MapOutput]
logs = filter isLog
isLog (Log _) = True
isLog _ = False
instance ToJSON MapOutput where
toJSON (Emit key value) = toJSON (key, value)
toJSON (Log msg) = toJSON msg
emit :: (ToJSON k, ToJSON v) => k -> v -> ViewMap ()
emit key value = ViewMap $ tell [Emit (toJSON key) (toJSON value)]
emitM :: (ToJSON k, ToJSON v) => ViewMap k -> ViewMap v -> ViewMap ()
emitM key value = do
key' <- key
value' <- value
emit key' value'
logMsg :: String -> ViewMap ()
logMsg msg = ViewMap $ tell [Log $ LogMessage msg]