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.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
type ViewMapT m a = WriterT [MapOutput] m a
type ViewMap a = ViewMapT Parser a
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 (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 = 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 = tell [Log $ LogMessage msg]