snaplet-mongoDB (empty) → 0.2
raw patch · 9 files changed
+1896/−0 lines, 9 filesdep +MonadCatchIO-transformersdep +basedep +bsonsetup-changed
Dependencies added: MonadCatchIO-transformers, base, bson, bytestring, compact-string-fix, containers, haskell-src-exts, mongoDB, mtl, parsec, regular, safe, snap, snap-core, template-haskell, text, time
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- snaplet-mongoDB.cabal +85/−0
- src/Snap/Snaplet/MongoDB.hs +330/−0
- src/Snap/Snaplet/MongoDB/FilterOps.hs +88/−0
- src/Snap/Snaplet/MongoDB/MongoEntity.hs +76/−0
- src/Snap/Snaplet/MongoDB/MongoValue.hs +307/−0
- src/Snap/Snaplet/MongoDB/Parse.hs +491/−0
- src/Snap/Snaplet/MongoDB/Template.hs +487/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Kamil Ciemniewski++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kamil Ciemniewski nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ snaplet-mongoDB.cabal view
@@ -0,0 +1,85 @@+-- snaplet-mongoDB.cabal auto-generated by cabal init. For additional+-- options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: snaplet-mongoDB++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.2++-- A short (one-line) description of the package.+Synopsis: Snap Framework MongoDB support as Snaplet++-- A longer description of the package.+-- Description: ++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Kamil Ciemniewski++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: ciemniewski.kamil@gmail.com++-- A copyright notice.+-- Copyright: ++Category: Web++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >= 1.6+++Library+ hs-source-dirs: src++ library+ exposed-modules: Snap.Snaplet.MongoDB+ , Snap.Snaplet.MongoDB.Template+ , Snap.Snaplet.MongoDB.FilterOps+ , Snap.Snaplet.MongoDB.MongoEntity+ , Snap.Snaplet.MongoDB.MongoValue+ , Snap.Snaplet.MongoDB.Parse+ + -- Packages needed in order to build this package.+ Build-depends:+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.10,+ bson == 0.1.6,+ compact-string-fix == 0.3.2,+ containers == 0.4.0.0,+ mongoDB == 1.1.1,+ mtl >= 2 && < 3,+ regular >= 0.3.2,+ safe,+ snap == 0.7.*,+ snap-core == 0.7.*,+ text >= 0.11 && < 0.12,+ time >= 1.1 && < 1.5,+ parsec == 3.1.1,+ haskell-src-exts == 1.11.1,+ template-haskell,+ MonadCatchIO-transformers == 0.2.2.2+ + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: + + extensions: + OverloadedStrings+ , FlexibleInstances+ , TypeSynonymInstances+ , MultiParamTypeClasses +
+ src/Snap/Snaplet/MongoDB.hs view
@@ -0,0 +1,330 @@+module Snap.Snaplet.MongoDB+ ( + MonadMongoDB(..)+ + , MongoDBSnaplet(..)+ , HasMongoDBState(..)++ , MongoValue (..)+ , MongoEntity (..)++ , mongoDBInit++ , insert+ , insertMany+ , insertWith+ , get+ , getMany+ , delete+ , deleteWhere+ , select+ , selectOne+ , count+ , save+ , update+ , updateWhere+ + , filters+ , updates+ + , offset+ , limit+ , orderAsc+ , orderDesc++ , objid2bs+ , bs2objid+ , bs2objid'+ , bs2cs+ , getObjId+ + , module Snap.Snaplet.MongoDB.FilterOps+ , module Snap.Snaplet.MongoDB.MongoEntity+ , module Snap.Snaplet.MongoDB.MongoValue+ , module Snap.Snaplet.MongoDB.Template+ , module Snap.Snaplet.MongoDB.Parse+ , MongoDB.Action+ , MongoDB.MonadIO'+ ) where++import Snap.Core+import Snap.Snaplet++import Prelude hiding (lookup, or)+import Control.Applicative+import Control.Monad+import Control.Monad.MVar+import Control.Monad.Error+import Data.Bson ((=:))+import qualified Data.Bson as BSON+import qualified Data.UString as US+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8+import qualified Data.CompactString.Internal as CSI+import Data.Maybe (catMaybes, fromJust)+import qualified Data.Map as Map+import Numeric (showHex, readHex)+import Safe+import Snap.Snaplet.MongoDB.FilterOps+import Snap.Snaplet.MongoDB.MongoEntity+import Snap.Snaplet.MongoDB.MongoValue+import Snap.Snaplet.MongoDB.Template+import Snap.Snaplet.MongoDB.Parse+import qualified Database.MongoDB as MongoDB+import qualified Database.MongoDB.Internal.Util as MongoDB+import Database.MongoDB.Query (Action, Failure(..), Database, access, master, AccessMode(..))+import qualified Database.MongoDB.Connection as MongoDB+import qualified System.IO.Pool as MPool++import Control.Monad.CatchIO hiding (Handler)++instance Exception String++------------------------------------------------------------------------------+-- | The 'MonadMongoDB' class. Minimal complete definition:+class MonadIO m => MonadMongoDB m where++ ----------------------------------------------------------------------------+ -- | Run given MongoDB action against the database+ withDB :: Action IO a -> m (Either Failure a)+ withDBUnsafe :: Action IO a -> m (Either Failure a)++++ ----------------------------------------------------------------------------+ -- | Same as 'withDB' but calls 'error' if there is an exception+ withDB' :: Action IO a -> m a+ withDB' run = do+ r <- withDB run + either (throw . show) return r+++data MongoDBSnaplet = MongoDBSnaplet {+ connPoll :: MPool.Pool IOError MongoDB.Pipe,+ appDatabase :: Database+}++------------------------------------------------------------------------------+-- |+class HasMongoDBState s where+ getMongoDBState :: Handler s s MongoDBSnaplet+ setMongoDBState :: MongoDBSnaplet -> Handler s s ()++ --modifyMongoDBState :: (MongoDBSnaplet -> MongoDBSnaplet) -> s -> s+ --modifyMongoDBState s = setMongoDBState s getMongoDBState++mongoDBInit :: MongoDB.Host -> Int -> US.UString -> SnapletInit b MongoDBSnaplet+mongoDBInit h n db =+ makeSnaplet "mongoDB" "MongoDB abstraction" Nothing $ do+ pool <- liftIO $ MPool.newPool (factoryForHost h) n+ return $ MongoDBSnaplet pool (db)+ where+ factoryForHost :: MongoDB.Host -> MPool.Factory IOError MongoDB.Pipe+ factoryForHost host = MPool.Factory (newRes h) (killRes) (isResExpired)+ + newRes :: MongoDB.Host -> ErrorT IOError IO MongoDB.Pipe+ newRes = MongoDB.connect+ + killRes :: MongoDB.Pipe -> IO ()+ killRes = MongoDB.close+ + isResExpired :: MongoDB.Pipe -> IO Bool+ isResExpired = MongoDB.isClosed++------------------------------------------------------------------------------+-- |+instance HasMongoDBState s => MonadMongoDB (Handler s s) where+ withDB run = do+ (MongoDBSnaplet pool db) <- getMongoDBState+ epipe <- liftIO $ runErrorT $ MPool.aResource pool+ case epipe of+ Left err -> return $ Left $ ConnectionFailure err+ Right pipe -> do+ liftIO (access pipe master db run)++ withDBUnsafe run = do+ (MongoDBSnaplet pool db) <- getMongoDBState+ epipe <- liftIO $ runErrorT $ MPool.aResource pool+ case epipe of+ Left err -> return $ Left $ ConnectionFailure err+ Right pipe -> do+ liftIO (access pipe UnconfirmedWrites db run)+++-- | Given a type in the type class 'MongoEntity', insert this as a new document in the database. The function will+-- yield the unique key for the new document.+insert :: (MongoDB.MonadIO' m, MongoEntity a) => a -> MongoDB.Action m (Key a)+insert obj = do+ (BSON.ObjId objId) <- MongoDB.insert (collectionName obj) (fromDocument $ encodeDocument obj)+ pure $! toKey objId+++-- | Similar to 'insert', this function inserts multiple documents into the databsae, yielding a unique key for each.+insertMany :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => [a] -> MongoDB.Action m [Key a]+insertMany [] = pure []+insertMany objs = do+ ids <- MongoDB.insertMany (collectionName $ head objs) (map (fromDocument . encodeDocument) objs)+ forM ids $ \x -> case x of+ BSON.ObjId objId -> pure $! toKey objId+ _ -> throwError $ MongoDB.QueryFailure 1000 "Expected object ID as result of 'insertMany'"++-- | Similar to 'insert', but allows you to specify the ID with which the object is to be created.+insertWith :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> a -> MongoDB.Action m (Key a)+insertWith key obj = do+ (BSON.ObjId objId) <- MongoDB.insert (collectionName obj) (("_id" =: fromKey key) : (fromDocument $ encodeDocument obj))+ pure $! toKey objId+++-- | Given a unique key for a 'MongoEntity', yield that entity. If no document with the specified ID was found, the+-- function will yield @Nothing@.+get :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> MongoDB.Action m (Maybe a)+get key = do+ let collection = collectionName (dummyFromKey key)+ result <- MongoDB.findOne (MongoDB.select ["_id" =: fromKey key] collection)+ case result of+ Just document -> do+ eObj <- runErrorT (decodeDocument $ toDocument document)+ case eObj of+ Left message -> throwError $ MongoDB.QueryFailure 1001 message+ Right obj -> pure (Just obj)+ Nothing ->+ pure Nothing++-- | The application of 'get' to many keys.+getMany :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => [Key a] -> MongoDB.Action m [Maybe a]+getMany = mapM get++-- | Delete the document with the specified key.+delete :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> MongoDB.Action m ()+delete key = do+ let collection = collectionName (dummyFromKey key)+ MongoDB.deleteOne (MongoDB.select ["_id" =: fromKey key] collection)++deleteWhere :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Document a -> MongoDB.Action m ()+deleteWhere doc = do+ MongoDB.delete (MongoDB.select (fromDocument doc) (collectionName (dummyFromDocument doc)))++count :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Document a -> MongoDB.Action m Int+count doc = do+ MongoDB.count (MongoDB.select (fromDocument doc) (collectionName (dummyFromDocument doc)))++type SelectorOption = MongoDB.Query -> MongoDB.Query++offset :: Int -> SelectorOption+offset n q = q { MongoDB.skip = fromIntegral n }++limit :: Int -> SelectorOption+limit n q = q { MongoDB.limit = fromIntegral n }++orderAsc :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> SelectorOption+orderAsc f q = q { MongoDB.sort = (filterFieldName (f undefined) =: (1 :: Int)) : MongoDB.sort q }++orderDesc :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> SelectorOption+orderDesc f q = q { MongoDB.sort = (filterFieldName (f undefined) =: ((-1) :: Int)) : MongoDB.sort q }+++-- | Select all matching documents from a collection in the database. This function yields a list of pairs of the unique+-- key and the 'MongoEntity' for each matching document in the collection.+--+-- The query can be made using either the quasi-quoted mongoDB query format:+--+-- @select [mongo| { userName: #{name}, userPassword: #{password} |] []@+--+-- Or using the filter operations:+--+-- @select (filters [UserName `eq` name, UserPassword `eq` password]) []@+--+-- /Note/: in the quasi-quotation the names of the fields correspond to the fields stored in the /database/, rather than+-- the fields of the record structure.+--+select :: (Functor m, MonadControlIO m, MongoEntity a) => Document a -> [SelectorOption] -> MongoDB.Action m [(Key a, a)]+select document options = do+ cursor <- MongoDB.find (foldr ($) (MongoDB.select (fromDocument document) (collectionName (dummyFromDocument document))) options)+ objects <- MongoDB.rest cursor+ values <- mapM fetchKeyValue objects+ return $ catMaybes values++-- | Similar to 'select', only yielding a single result.+selectOne :: (Functor m, MonadControlIO m, MongoEntity a) => Document a -> [SelectorOption] -> MongoDB.Action m (Maybe (Key a, a))+selectOne document options = do+ result <- MongoDB.findOne (foldr ($) (MongoDB.select (fromDocument document) (collectionName (dummyFromDocument document))) options)+ case result of+ Just obj -> fetchKeyValue obj+ Nothing -> pure Nothing+++save :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> a -> MongoDB.Action m ()+save key obj = do+ MongoDB.save (collectionName obj) (("_id" := BSON.ObjId (fromKey key)) : (fromDocument $ encodeDocument obj))+++update :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> Document a -> MongoDB.Action m ()+update key updateDoc = do+ MongoDB.modify (MongoDB.select [ "_id" =: (fromKey key) ] (collectionName (dummyFromKey key))) (fromDocument updateDoc)++updateWhere :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Document a -> Document a -> MongoDB.Action m ()+updateWhere document updateDoc = do+ MongoDB.modify (MongoDB.select (fromDocument document) (collectionName (dummyFromDocument document))) (fromDocument updateDoc)+++filters :: (MongoEntity a) => [FilterOp] -> Document a+filters = toDocument++updates :: (MongoEntity a) => [UpdateOp] -> Document a+updates = toDocument+++fetchKeyValue :: (Functor m, MonadControlIO m, MongoEntity a) => BSON.Document -> MongoDB.Action m (Maybe (Key a, a))+fetchKeyValue doc = do+ case BSON.look "_id" doc of+ Just i ->+ case i of+ BSON.ObjId objId -> do+ eObj <- runErrorT (decodeDocument $ toDocument doc)+ case eObj of+ Left message -> throwError $ MongoDB.QueryFailure 1001 message+ Right obj -> pure $ Just (toKey objId, obj)+ _ -> throwError $ MongoDB.QueryFailure 1000 "Expected _id field to be an ObjectId in result of selection"+ Nothing ->+ throwError $ MongoDB.QueryFailure 1000 "Expected to find an _id field in result of selection"+++------------------------------------------------------------------------------+-- | Convert 'ObjectId' into 'ByteString'+objid2bs :: ObjectId -> BS.ByteString+objid2bs (Oid a b) = B8.pack . showHex a . showChar '-' . showHex b $ ""+++------------------------------------------------------------------------------+-- | Convert 'ByteString' into 'ObjectId'+bs2objid :: BS.ByteString -> Maybe ObjectId+bs2objid bs = do+ case B8.split '-' bs of+ (a':b':_) -> do+ a <- fmap fst . headMay . readHex . B8.unpack $ a'+ b <- fmap fst . headMay . readHex . B8.unpack $ b'+ return $ Oid a b+ _ -> Nothing++------------------------------------------------------------------------------+-- | Like 'bs2objid', but may blow with an error if the 'ByteString' can't be+-- converted to an 'ObjectId'+bs2objid' :: BS.ByteString -> ObjectId+bs2objid' = fromJust . bs2objid++bs2cs :: BS.ByteString -> US.UString+bs2cs = CSI.CS+++------------------------------------------------------------------------------+-- | If the 'Document' has an 'ObjectId' in the given field, return it as+-- 'ByteString'+getObjId :: US.UString -> BSON.Document -> Maybe BS.ByteString+getObjId v d = MongoDB.lookup v d >>= fmap objid2bs+++dummyFromKey :: Key a -> a+dummyFromKey _ = undefined++dummyFromDocument :: Document a -> a+dummyFromDocument _ = undefined
+ src/Snap/Snaplet/MongoDB/FilterOps.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.MongoDB.FilterOps+ ( FilterOp+ + , (==?)+ , (/=?)+ , eq, ne, lt, lte, gt, gte+ , or, ors+ , isIn, notIn+ + , UpdateOp+ , (==:)+ , set+ , inc, dec+ , pop, push, pull, pushAll, pullAll+ , addToSet, addManyToSet+ ) where++import Prelude hiding (or)+import qualified Data.Bson as BSON+import Snap.Snaplet.MongoDB.MongoValue+import Snap.Snaplet.MongoDB.MongoEntity+++infix 0 ==? -- Alias to eq operation+infix 0 /=? -- Alias to neq operation+infix 0 ==: -- Alias to set operation++type FilterOp = BSON.Field++(==?), (/=?), (==:) :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> v -> FilterOp+(==?) = eq+(/=?) = ne+(==:) = set++stdFilterDef :: (MongoEntity a, MongoValue v) => BSON.Label -> (v -> Filter a) -> v -> FilterOp+stdFilterDef op f v =+ filterFieldName (f undefined) := BSON.Doc [op := toValue v]++eq, ne, lt, lte, gt, gte :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> v -> FilterOp+eq f v = filterFieldName (f undefined) := toValue v+ne = stdFilterDef "$ne"+lt = stdFilterDef "$lt"+lte = stdFilterDef "$lte"+gt = stdFilterDef "$gt"+gte = stdFilterDef "$gte"++or :: BSON.Field -> BSON.Field -> FilterOp+or x y = "$or" := BSON.Doc [x, y]++ors :: [BSON.Field] -> BSON.Field+ors fs = "$or" := BSON.Doc fs++isIn, notIn :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> [v] -> FilterOp+isIn f vs = filterFieldName (f undefined) := BSON.Doc [ "$in" := BSON.Array (map toValue vs) ]+notIn f vs = filterFieldName (f undefined) := BSON.Doc [ "$nin" := BSON.Array (map toValue vs) ]+++type UpdateOp = BSON.Field++set :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> v -> UpdateOp+set f v = "$set" := BSON.Doc [ filterFieldName (f v) := toValue v ]++inc, dec :: (MongoEntity a, Num v, MongoValue v) => (v -> Filter a) -> v -> UpdateOp+inc f v = "$inc" := BSON.Doc [ filterFieldName (f v) := toValue v ]+dec f v = "$dec" := BSON.Doc [ filterFieldName (f v) := toValue v ]++push, addToSet, pull :: (MongoEntity a, MongoValue v) => ([v] -> Filter a) -> v -> UpdateOp+push f v = "$push" := BSON.Doc [ filterFieldName (f [v]) := toValue v ]+addToSet f v = "$addToSet" := BSON.Doc [ filterFieldName (f undefined) := toValue v ]+pull f v = "$pull" := BSON.Doc [ filterFieldName (f undefined) := toValue v ]++pushAll, pullAll, addManyToSet :: (MongoEntity a, MongoValue v) => ([v] -> Filter a) -> [v] -> UpdateOp+pushAll f v = "$pushAll" := BSON.Doc [ filterFieldName (f undefined) := BSON.Array (map toValue v) ]+pullAll f v = "$pullAll" := BSON.Doc [ filterFieldName (f undefined) := BSON.Array (map toValue v) ]+addManyToSet f v = "$addToSet" := BSON.Doc [ filterFieldName (f undefined) := BSON.Doc [ "$each" := BSON.Array (map toValue v) ] ]++pop :: (MongoEntity a, MongoValue v) => ([v] -> Filter a) -> UpdateOp+pop f = "$pop" := BSON.Doc [ filterFieldName (f undefined) := BSON.Int32 1 ]++++-- Local Variables:+-- mode : Haskell+-- fill-column : 120+-- default-justification : left+-- End:
+ src/Snap/Snaplet/MongoDB/MongoEntity.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-}++module Snap.Snaplet.MongoDB.MongoEntity+ ( MongoEntity (..)+ ) where+++import Control.Applicative+import Control.Monad.Error+import qualified Data.Bson as BSON+import Data.Monoid+import qualified Database.MongoDB as DB+import Snap.Snaplet.MongoDB.MongoValue+import Numeric (readHex)+import Text.Read+import qualified Text.ParserCombinators.ReadP as R+import qualified Text.ParserCombinators.ReadPrec as R (lift, readS_to_Prec)+++-- | Any type that is an instance of this type class can be stored and retrieved as an object from a MongoDB collection.+class (Show (Key a), MongoValue (Key a)) => MongoEntity a where+ data Key a+ data Filter a+ data Document a+ + -- | Convert an 'ObjectId' to a 'Key'.+ toKey :: ObjectId -> Key a+ -- | Convert a 'Key' to an 'ObjectId'+ fromKey :: Key a -> ObjectId+ + -- | Convert a 'BSON.Document' to a 'Document'.+ toDocument :: BSON.Document -> Document a+ -- | Convert a 'Document' to a 'BSON.Document'.+ fromDocument :: Document a -> BSON.Document+ + -- | Yields the name of the collection to which this type belongs.+ collectionName :: a -> DB.Collection+ -- | Yields the name of the corresponding field in a collection for the given filter.+ filterFieldName :: Filter a -> BSON.Label+ + -- | Encode an object into a 'BSON.Document' that can be stored in a collection.+ encodeDocument :: a -> Document a+ -- | Decode a 'BSON.Document' into this type; possibly failing.+ decodeDocument :: (Applicative m, Monad m) => Document a -> ErrorT String m a+++instance (MongoEntity a) => MongoValue (Key a) where+ toValue = BSON.ObjId . fromKey+ fromValue (BSON.ObjId o) = return $ toKey o+ fromValue v = expected "ObjectId" v++instance (MongoEntity a) => MongoValue (Document a) where+ toValue = toValue . fromDocument+ fromValue (BSON.Doc doc) = return $ toDocument doc+ fromValue v = expected "Document" v++instance (MongoEntity a) => Monoid (Document a) where+ mempty = toDocument []+ mappend x y = toDocument (fromDocument x ++ fromDocument y)++instance (MongoEntity a) => Show (Key a) where+ show = show . fromKey++instance (MongoEntity a) => Read (Key a) where+ readPrec = do+ [(x, "")] <- readHex <$> R.lift (R.count 8 R.get)+ y <- R.readS_to_Prec $ const readHex+ return (toKey (BSON.Oid x y))++++-- Local Variables:+-- mode : Haskell+-- fill-column : 120+-- default-justification : left+-- End:
+ src/Snap/Snaplet/MongoDB/MongoValue.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeFamilies #-}+{-# LANGUAGE TupleSections, TypeSynonymInstances, RankNTypes, ScopedTypeVariables, IncoherentInstances #-}++module Snap.Snaplet.MongoDB.MongoValue+ ( MongoValue (..)+ , BSON.Value (..)+-- , BSON.Document (..)+ , BSON.Field (..)+ , BSON.ObjectId (..)+ , nullObjectId+ , expected+-- , lookMaybe+ , lookupThrow+ ) where++import Prelude hiding (lookup, or)+import Control.Applicative+import Control.Monad.Error+import Data.Bson (Field ((:=)), ObjectId (..))+import qualified Data.Bson as BSON+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Char+import qualified Data.CompactString.UTF8 as CS+import Data.Int+import Data.List (find)+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import Data.Time+import Data.Time.Clock.POSIX+import Text.Printf++++-- | This type class represents all types which can be marshalled too and from the BSON format.+class MongoValue a where+ toValue :: a -> BSON.Value+ fromValue :: (Applicative m, Monad m) => BSON.Value -> ErrorT String m a+++expected :: (Monad m) => String -> BSON.Value -> ErrorT String m a+expected what was =+ throwError $ printf "Expected %s; found %s" what (describeType was)+ where+ describeType :: BSON.Value -> String+ describeType (BSON.Float _) = "Float"+ describeType (BSON.String _) = "String"+ describeType (BSON.Doc _) = "Document"+ describeType (BSON.Array n) = printf "Array (BSON.with %i elements)" (length n)+ describeType (BSON.Bin _) = "Binary"+ describeType (BSON.Fun _) = "Function"+ describeType (BSON.Uuid _) = "UUID"+ describeType (BSON.Md5 _) = "MD5"+ describeType (BSON.UserDef _) = "UserDefined"+ describeType (BSON.ObjId _) = "ObjectId"+ describeType (BSON.Bool _) = "Bool"+ describeType (BSON.UTC _) = "UTCTime"+ describeType (BSON.Null ) = "null"+ describeType (BSON.RegEx _) = "RegEx"+ describeType (BSON.JavaScr _) = "JavaScript"+ describeType (BSON.Sym _) = "Symbol"+ describeType (BSON.Int32 _) = "Int32"+ describeType (BSON.Int64 _) = "Int64"+ describeType (BSON.Stamp _) = "Stamp"+ describeType (BSON.MinMax _) = "MinMax"+++-- | Represents a null 'ObjectId' (all zeros).+nullObjectId :: ObjectId+nullObjectId = Oid 0 0++lookMaybe :: T.Text -> BSON.Document -> Maybe BSON.Value+lookMaybe name doc =+ let name' = textToCompactString name in maybe Nothing (Just . BSON.value) $ find ((name' ==) . BSON.label) doc++lookupThrow :: (Applicative m, Monad m, MongoValue a) => T.Text -> BSON.Document -> ErrorT String m a+lookupThrow name doc =+ case lookMaybe name doc of+ Just val -> fromValue val+ Nothing -> throwError $ printf "Could not find field '%s'" (T.unpack name)++instance MongoValue BSON.Value where+ toValue = id+ fromValue = return . id++instance MongoValue BSON.Document where+ toValue = BSON.Doc+ fromValue (BSON.Doc d) = pure d+ fromValue v = expected "Document" v++instance MongoValue () where+ toValue _ = BSON.Null+ fromValue BSON.Null = pure ()+ fromValue v = expected "null" v++instance MongoValue Bool where+ toValue = BSON.Bool+ fromValue (BSON.Bool x) = pure x+ fromValue v = expected "boolean" v++instance MongoValue BSON.UString where+ toValue = BSON.String+ fromValue (BSON.String x ) = pure x+ fromValue (BSON.Sym (BSON.Symbol x)) = pure x+ fromValue v = expected "string or symbol" v++instance MongoValue T.Text where+ toValue = BSON.String . textToCompactString+ fromValue (BSON.String x ) = pure $! compactStringToText x+ fromValue (BSON.Sym (BSON.Symbol x)) = pure $! compactStringToText x+ fromValue v = expected "string or symbol" v++instance MongoValue LT.Text where+ toValue = BSON.String . lazyTextToCompactString+ fromValue (BSON.String x ) = pure $! compactStringToLazyText x+ fromValue (BSON.Sym (BSON.Symbol x)) = pure $! compactStringToLazyText x+ fromValue v = expected "string or symbol" v++instance MongoValue (Maybe BSON.Value) where+ toValue Nothing = BSON.Null+ toValue (Just x) = x+ + fromValue BSON.Null = pure Nothing+ fromValue x = pure (Just x)++instance (MongoValue a) => MongoValue (Maybe a) where+ toValue Nothing = BSON.Null+ toValue (Just x) = toValue x+ + fromValue BSON.Null = pure Nothing+ fromValue x = Just <$> (fromValue x)+++instance (MongoValue a) => MongoValue [a] where+ toValue = BSON.Array . map toValue+ fromValue (BSON.Array x) = mapM fromValue x+ fromValue v = expected "array" v++instance (MongoValue a, MongoValue b) => MongoValue (Either a b) where+ toValue (Left x) = BSON.Doc [ "_type" := (BSON.String $ BSON.u "Left" ), "value" := toValue x ]+ toValue (Right y) = BSON.Doc [ "_type" := (BSON.String $ BSON.u "Right"), "value" := toValue y ]+ + fromValue (BSON.Doc doc) = do+ side <- fmap (map toLower) $ BSON.lookup "_type" doc+ case side of+ ("left" :: String) -> (return . Left) =<< fromValue =<< BSON.look "value" doc+ ("right" :: String) -> (return . Right) =<< fromValue =<< BSON.look "value" doc+ other -> throwError $ "Expected either 'left' or 'right', found '" ++ other ++ "'"+ fromValue v = expected "document" v++roundTo :: (RealFrac a) => a -> a -> a+roundTo mult n = fromIntegral (round (n / mult)) * mult++instance MongoValue UTCTime where+ toValue = BSON.UTC . posixSecondsToUTCTime . roundTo (1 / 1000) . utcTimeToPOSIXSeconds+ fromValue (BSON.UTC x) = pure x+ fromValue v = expected "UTCTime" v++instance MongoValue POSIXTime where+ toValue = BSON.UTC . posixSecondsToUTCTime . roundTo (1 / 1000)+ fromValue (BSON.UTC x) = pure $! utcTimeToPOSIXSeconds x+ fromValue v = expected "UTCTime" v++instance MongoValue BS.ByteString where+ toValue = BSON.Bin . BSON.Binary+ fromValue (BSON.Bin (BSON.Binary x)) = pure x+ fromValue v = expected "binary" v++instance MongoValue BSL.ByteString where+ toValue = BSON.Bin . BSON.Binary . BS.concat . BSL.toChunks+ fromValue (BSON.Bin (BSON.Binary x)) = pure $! BSL.fromChunks [x]+ fromValue v = expected "binary" v++++fitInt :: forall m b a. (Applicative m, Monad m, PrintfArg a, Integral a, Integral b, Bounded b) => String -> a -> ErrorT String m b+fitInt t n =+ let l = minBound :: b+ h = maxBound :: b+ in if fromIntegral l <= n && n <= fromIntegral h+ then pure $! fromIntegral n+ else throwError $ printf "Integer value %i was out of range for type %s" n t+++instance MongoValue Int32 where+ toValue = BSON.Int32+ fromValue (BSON.Int32 x) = pure x+ fromValue (BSON.Int64 x) = fitInt "Int32" x+ fromValue (BSON.Float x) = pure $! round x+ fromValue v = expected "Int32, Int64 or Float" v++instance MongoValue Int64 where+ toValue = BSON.Int64+ fromValue (BSON.Int32 x) = pure $! fromIntegral x+ fromValue (BSON.Int64 x) = pure x+ fromValue (BSON.Float x) = pure $! round x+ fromValue v = expected "Int32, Int64 or Float" v++instance MongoValue Int where+ toValue = BSON.Int64 . fromIntegral+ fromValue (BSON.Int32 x) = pure $! fromIntegral x+ fromValue (BSON.Int64 x) = pure $! fromEnum x+ fromValue (BSON.Float x) = pure $! round x+ fromValue v = expected "Int32, Int64 or Float" v++instance MongoValue Integer where+ toValue = BSON.Int64 . fromIntegral+ fromValue (BSON.Int32 x) = pure $! fromIntegral x+ fromValue (BSON.Int64 x) = pure $! fromIntegral x+ fromValue (BSON.Float x) = pure $! round x+ fromValue v = expected "Int32, Int64 or Float" v++instance MongoValue Float where + toValue = BSON.Float . realToFrac+ fromValue (BSON.Float x) = pure $! realToFrac x+ fromValue (BSON.Int32 x) = pure $! fromIntegral x+ fromValue (BSON.Int64 x) = pure $! fromIntegral x+ fromValue v = expected "Int32, Int64 or Float" v++instance MongoValue Double where+ toValue = BSON.Float+ fromValue (BSON.Float x) = pure x+ fromValue (BSON.Int32 x) = pure $! fromIntegral x+ fromValue (BSON.Int64 x) = pure $! fromIntegral x+ fromValue v = expected "Int32 or Int64" v+ +instance MongoValue ObjectId where+ toValue = BSON.ObjId+ fromValue (BSON.ObjId x) = pure x+ fromValue v = expected "ObjectId" v++instance (MongoValue a, MongoValue b) => MongoValue (a, b) where+ toValue (x, y) = BSON.Array [toValue x, toValue y]+ fromValue v @ (BSON.Array xs) =+ case xs of+ [x, y] -> (,) <$> fromValue x <*> fromValue y+ _ -> expected "Array (with 2 elements)" v+ fromValue v = expected "Array (with 2 elements)" v++instance (MongoValue a, MongoValue b, MongoValue c) => MongoValue (a, b, c) where+ toValue (x, y, z) = BSON.Array [toValue x, toValue y, toValue z]+ fromValue v @ (BSON.Array xs) =+ case xs of+ [x, y, z] -> (,,) <$> fromValue x <*> fromValue y <*> fromValue z+ _ -> expected "Array (with 3 elements)" v+ fromValue v = expected "Array (with 3 elements)" v+++-- | Instance of the 'MongoValue' type class for a map of strict 'T.Text' to some value which also an instance of the+-- 'MongoValue' type class. This type class is provided for more efficient storage of maps with textual keys.+--+-- For example, the map @M.fromList [("cat", 1), ("dog", 2), ("mat", 3)]@ would yield the JSON equivalent of:+-- @{ cat: 1, dog: 2, mat: 3 }@.+--+instance (MongoValue val) => MongoValue (M.Map T.Text val) where+ toValue m = BSON.Doc $ map (\(k, v) -> textToCompactString k := toValue v) $ M.toList m+ fromValue (BSON.Doc m) = do+ elements <- mapM (\ (k := v) -> do+ val <- fromValue v+ pure (compactStringToText k, val)) m+ pure $! M.fromList elements+ fromValue v = expected "Document" v++-- | Instance of the 'MongoValue' type class for a map of lazy 'LT.Text' to some value which also an instance of the+-- 'MongoValue' type class. This type class is provided for more efficient storage of maps with textual keys.+--+-- For example, the map @M.fromList [("cat", 1), ("dog", 2), ("mat", 3)]@ would yield the JSON equivalent of:+-- @{ cat: 1, dog: 2, mat: 3 }@.+--+instance (MongoValue val) => MongoValue (M.Map LT.Text val) where+ toValue m = BSON.Doc $ map (\(k, v) -> lazyTextToCompactString k := toValue v) $ M.toList m+ fromValue (BSON.Doc m) = do+ elements <- mapM (\ (k := v) -> do+ val <- fromValue v+ pure (compactStringToLazyText k, val)) m+ pure $! M.fromList elements+ fromValue v = expected "Document" v+++instance (Ord key, MongoValue key, MongoValue val) => MongoValue (M.Map key val) where+ toValue = toValue . M.toList+ fromValue v = M.fromList <$> fromValue v+ +++compactStringToText :: CS.CompactString -> T.Text+compactStringToText = T.decodeUtf8 . CS.toByteString++textToCompactString :: T.Text -> CS.CompactString+textToCompactString = CS.fromByteString_ . T.encodeUtf8++compactStringToLazyText :: CS.CompactString -> LT.Text+compactStringToLazyText =+ LT.decodeUtf8 . (\x -> BSL.fromChunks [x]) . CS.toByteString++lazyTextToCompactString :: LT.Text -> CS.CompactString+lazyTextToCompactString =+ CS.fromByteString_ . BS.concat . BSL.toChunks . LT.encodeUtf8++-- Local Variables:+-- mode : Haskell+-- fill-column : 120+-- default-justification : left+-- End:
+ src/Snap/Snaplet/MongoDB/Parse.hs view
@@ -0,0 +1,491 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+++module Snap.Snaplet.MongoDB.Parse+ ( mongo+ ) where++import Control.Applicative+--import qualified Data.Bson as BSON+--import Data.Bson (Field ((:=)))+import Data.Char (isSpace, digitToInt)+import Data.Text (Text)+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax.Internals+import Language.Haskell.TH.Quote+import qualified Language.Haskell.Exts as H+import Snap.Snaplet.MongoDB.MongoValue+import Snap.Snaplet.MongoDB.MongoEntity+import Text.Parsec hiding (many, (<|>))++mongo :: QuasiQuoter+mongo = QuasiQuoter { quoteExp = mongoQuote }++mongoQuote :: String -> Q Exp+mongoQuote input = do+ expr <- runParserT parseMongo () "" input+ case expr of+ Left err -> error $ show err+ Right e -> return e+++type Parser = ParsecT String () Q++parseMongo :: Parser Exp+parseMongo = do+ doc <- whitespace *> topObjectDef+ return ((VarE 'toDocument) `AppE` doc)+ where+ topObjectDef =+ singleField <|> multipleFields+ singleField =+ (ListE . (: [])) <$> objectField+ multipleFields =+ objectDef++whitespace :: Parser ()+whitespace =+ skipMany . satisfy $ isSpace++lexeme :: Parser a -> Parser a+lexeme p =+ p <* whitespace++objectDef :: Parser Exp+objectDef =+ (lexeme (char '{') <?> "'{' at start of JSON object")+ *> (lexeme objectFields) <*+ (lexeme (char '}') <?> "'}' at end of JSON object")++objectFields :: Parser Exp+objectFields = do+ ListE <$> sepBy objectField (lexeme $ char ',')++objectField :: Parser Exp+objectField = do+ name <- lexeme (identifier <|> stringLiteral) <?> "identifier for field definition"+ _ <- lexeme (char ':')+ val <- lexeme (fieldValue <|> arrayValue <|> objectDef) <?> ("value for field `" ++ name ++ "'")+ + return (InfixE (Just . LitE . StringL $ name)+ (ConE '(:=))+ (Just (AppE (VarE 'toValue) val)))++arrayValue :: Parser Exp+arrayValue = do+ (lexeme (char '[') <?> "'[' at start of JSON array")+ *> (lexeme arrayElements) <*+ (lexeme (char ']') <?> "']' at end of JSON array")+ where+ arrayElements = + ListE . map ((VarE 'toValue) `AppE`) <$> sepBy (fieldValue <|> arrayValue <|> objectDef) (lexeme $ char ',')+ ++fieldValue :: Parser Exp+fieldValue = do+ (stringValue <|> altBaseIntegerValue <|> numericalValue <|> boolNullValue <|> pasteValue) <?> "field value"+ where+ stringValue =+ ((`SigE` (ConT ''Text)) . LitE . StringL) <$> stringLiteral++ numericalValue = do+ int <- decimal+ rl <- do+ (Left . (+ fromIntegral int) <$> denom) <|> pure (Right int)+ mEx <- option Nothing (Just <$> (oneOf "eE" *> (option id ((char '-' *> pure negate) <|> (char '+' *> pure id)) <*> decimal)))+ case mEx of+ Just ex -> pure $! ((`SigE` (ConT ''Double)) . LitE . RationalL. toRational $ either id fromIntegral rl * (10 ** fromIntegral ex))+ Nothing -> + case rl of+ Left f -> pure $! ((`SigE` (ConT ''Double)) . LitE . RationalL . toRational $ f)+ Right i -> pure $! ((`SigE` (ConT ''Integer)) . LitE . IntegerL $ i)+ altBaseIntegerValue =+ ((`SigE` (ConT ''Integer)) . LitE . IntegerL) <$> (hexadecimal <|> octal <|> binary)+ hexadecimal = try (char '0' *> oneOf "xX" *> numberBuilder 16 hexDigit)+ octal = try (char '0' *> oneOf "oO" *> numberBuilder 8 octDigit)+ binary = try (char '0' *> oneOf "bB" *> numberBuilder 2 (char '0' <|> char '1'))+ denom =+ let op = ((/ 10) .) . ((+) . (fromIntegral . digitToInt))+ in pure (foldr op 0.0) <*> (char '.' *> many1 digit)+ + boolNullValue =+ identifier >>= (\i -> case i of+ "true" -> pure . ConE $ 'True+ "false" -> pure . ConE $ 'False+ "null" -> pure . ConE $ '()+ _ -> unexpected i)+ pasteValue = do+ text <- (char '#' *> betweenBraces)+ case H.parseExp text of+ H.ParseOk expr -> return (mapExpToTH expr)+ H.ParseFailed _ msg -> parserFail msg+ +betweenBraces :: Parser String+betweenBraces = do+ between (char '{') (char '}') (concat <$> many insideBraces)+ where+ insideBraces = do+ ((\s -> '{' : s ++ "}") <$> betweenBraces) <|> ((: []) <$> satisfy (/= '}'))+++identifier :: Parser String+identifier =+ try (ident <?> "identifier")+ where+ ident = do+ c <- (letter <|> char '_' <|> char '$')+ cs <- many (alphaNum <|> char '_')+ return (c : cs)+++stringLiteral :: Parser String+stringLiteral =+ (do+ str <- between (char '"')+ (char '"' <?> "end of string")+ (many stringChar)+ return . foldr (maybe id (:)) "" $ str) <?> "string literal"++stringChar :: Parser (Maybe Char)+stringChar =+ ( do+ c <- stringLetter+ return $ Just c) <|> stringEscape <?> "string character"++stringLetter :: Parser Char+stringLetter =+ satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))++stringEscape :: Parser (Maybe Char)+stringEscape =+ char '\\' *> ((escapeGap *> return Nothing) <|>+ (escapeEmpty *> return Nothing) <|>+ (Just <$> escapeCode ))+ where+ escapeEmpty = char '&'+ escapeGap = many1 space >> (char '\\' <?> "end of string gap")+ escapeCode = charEsc <|> charNum <|> charAscii <|> charControl <?> "escape code"+ + charControl = char '^' *> ((\c -> toEnum (fromEnum c - fromEnum 'A')) <$> upper)+ charNum =+ (toEnum . fromInteger) <$> (decimal <|> (char 'o' *> numberBuilder 8 octDigit)+ <|> (char 'x' *> numberBuilder 16 hexDigit))+ charEsc =+ choice (map parseEsc escMap)+ where+ parseEsc (c, code) = char c *> pure code+ + charAscii =+ choice (map parseAscii asciiMap)+ where+ parseAscii (asc, code) = try (string asc *> pure code)+ + escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"+ asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)++ ascii2codes = [ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "EM", "FS", + "GS", "RS", "US", "SP" ]+ ascii3codes = [ "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "DLE",+ "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "SUB",+ "ESC", "DEL" ]+ ascii2 = [ '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI', '\EM',+ '\FS', '\GS', '\RS', '\US', '\SP' ]+ ascii3 = [ '\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',+ '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',+ '\CAN', '\SUB', '\ESC', '\DEL' ]+++numberBuilder :: Integer -> Parser Char -> Parser Integer+numberBuilder base baseDigit = do+ digits <- many1 baseDigit+ let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits+ seq n (return n)++decimal :: Parser Integer+decimal = numberBuilder 10 digit+ ++------------------------------------------------------------------------------------------------------------------------+++mapQName :: H.QName -> Name+mapQName (H.Qual modu name) = Name (OccName $ strFromName name) (NameQ (ModName $ strFromModule modu))+mapQName (H.UnQual name) = mkName (strFromName name)+mapQName (H.Special con) = + case con of+ H.UnitCon -> '()+ H.ListCon -> '[]+ H.FunCon -> mkName "(->)"+ H.TupleCon _ n -> mkName ('(' : replicate n ',' ++ ")")+ H.Cons -> '(:)+-- H.UnboxedSingleCon -> '(# #)+ H.UnboxedSingleCon -> error "No name for unboxed constructor"++mapName :: H.Name -> Name+mapName = mkName . strFromName++strFromName :: H.Name -> String+strFromName (H.Ident str) = str+strFromName (H.Symbol op) = op++strFromModule :: H.ModuleName -> String+strFromModule (H.ModuleName name) = name++mapDecl :: H.Decl -> [Dec]+mapDecl (H.TypeDecl _ name binds typ) = [TySynD (mapName name) (map mapTypeBind binds) (mapTypeToTH typ)]+mapDecl (H.TypeFamDecl _ name binds mKind) = [FamilyD TypeFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)]+mapDecl (H.DataDecl _ H.DataType ctx name binds qConDecl deriv) = [DataD (mapContext ctx) (mapName name) (map mapTypeBind binds)+ (map mapQCon qConDecl) (map (mapQName . fst) deriv)]+mapDecl (H.DataDecl _ H.NewType ctx name binds qConDecl deriv) = [NewtypeD (mapContext ctx) (mapName name) (map mapTypeBind binds)+ (mapQCon (head qConDecl)) (map (mapQName . fst) deriv)]+mapDecl (H.GDataDecl _ _ _ _ _ _ _ _) = error "No support for GADTs in Template Haskell"+mapDecl (H.DataFamDecl _ _ name binds mKind) = [FamilyD DataFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)]+mapDecl (H.TypeInsDecl _ _ _) = error "No support for type instances"+mapDecl (H.DataInsDecl _ H.DataType _ _ _) = error "No support for data instances"+mapDecl (H.DataInsDecl _ H.NewType _ _ _ ) = error "No support for data instances"+mapDecl (H.GDataInsDecl _ _ _ _ _ _) = error "No support for GADTs in Template Haskell"+mapDecl (H.ClassDecl _ ctx name binds funDeps classDecls) = [ClassD (mapContext ctx) (mapName name) (map mapTypeBind binds)+ (map mapFunDep funDeps) (map mapClassDecl classDecls)]+mapDecl (H.InstDecl _ ctx _ types instDecls) = [InstanceD (mapContext ctx) (mapTypeToTH (head types)) (map mapInstDecl instDecls)]+mapDecl (H.DerivDecl _ _ _ _) = error "No support for standalone deriving declarations in Template Haskell"+mapDecl (H.InfixDecl _ _ _ _) = error "No support for operator fixity declarations in Template Haskell"+mapDecl (H.DefaultDecl _ _) = error "No support for default declarations in Template Haskell"+mapDecl (H.SpliceDecl _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)"+mapDecl (H.TypeSig _ names typ) = map (flip SigD (mapTypeToTH typ) . mapName) names+mapDecl (H.FunBind matches) = [FunD (matchName (head matches)) (map mapClause matches)]+mapDecl (H.PatBind _ pat _ rhs binds) = [ValD (mapPatToTH pat) (mapRhs rhs) (mapBinds binds)]+mapDecl (H.ForImp _ cc safe str name typ) = [ForeignD (ImportF (mapCC cc) (mapSafety safe) str (mapName name) (mapTypeToTH typ))]+mapDecl (H.ForExp _ cc str name typ) = [ForeignD (ExportF (mapCC cc) str (mapName name) (mapTypeToTH typ))]+mapDecl (H.RulePragmaDecl _ _) = error "No support for RULES pragma in Template Haskell"+mapDecl (H.DeprPragmaDecl _ _) = error "No support for DEPRECATED pragma in Template Haskell"+mapDecl (H.WarnPragmaDecl _ _) = error "No support for WARNING pragma in Template Haskell"+mapDecl (H.InlineSig _ _ _ name) = [PragmaD (InlineP (mapQName name) (InlineSpec True False Nothing))]+mapDecl (H.InlineConlikeSig _ _ _) = error "No current support for INLINE CONLIKE pragma"+mapDecl (H.SpecSig _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) Nothing)]+mapDecl (H.SpecInlineSig _ _ _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) (Just (InlineSpec True False Nothing)))]+mapDecl (H.InstSig _ _ _ _) = error "No support for SPECIALISE instance pragma in Template Haskell (I think...)"+mapDecl (H.AnnPragma _ _) = error "No support for ANN pragma in Template Haskell"++mapCC :: H.CallConv -> Callconv+mapCC (H.StdCall) = StdCall+mapCC (H.CCall ) = CCall++mapSafety :: H.Safety -> Safety+mapSafety (H.PlayRisky ) = Unsafe+mapSafety (H.PlaySafe t) = if t then Threadsafe else Safe+ +matchName :: H.Match -> Name+matchName (H.Match _ name _ _ _ _) = mapName name++mapClause :: H.Match -> Clause+mapClause (H.Match _ _ pats _ rhs binds) = Clause (map mapPatToTH pats) (mapRhs rhs) (mapBinds binds)++mapRhs :: H.Rhs -> Body+mapRhs (H.UnGuardedRhs e) = NormalB (mapExpToTH e)+mapRhs (H.GuardedRhss guards) =+ GuardedB (map mapGRhs guards)+ where+ mapGRhs (H.GuardedRhs _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e)++ +mapInstDecl :: H.InstDecl -> Dec+mapInstDecl (H.InsDecl decl) = head (mapDecl decl)+mapInstDecl _ = error "Unsupported"++mapClassDecl :: H.ClassDecl -> Dec+mapClassDecl (H.ClsDecl decl) = head (mapDecl decl)+mapClassDecl _ = error "Unsupported"++mapFunDep :: H.FunDep -> FunDep+mapFunDep (H.FunDep xs ys) = FunDep (map mapName xs) (map mapName ys)++mapQCon :: H.QualConDecl -> Con+mapQCon (H.QualConDecl _ [] [] conDecl) = mapCon conDecl+mapQCon (H.QualConDecl _ binds ctx conDecl) = ForallC (map mapTypeBind binds) (mapContext ctx) (mapCon conDecl)++mapCon :: H.ConDecl -> Con+mapCon (H.ConDecl name args) = NormalC (mapName name) (map mapBangType args)+mapCon (H.InfixConDecl x name y) = InfixC (mapBangType x) (mapName name) (mapBangType y)+mapCon (H.RecDecl name fields) = RecC (mapName name) $ map (uncurry mapFieldDecl) $ concatMap (uncurry ((. repeat) . zip)) fields++mapFieldDecl :: H.Name -> H.BangType -> VarStrictType+mapFieldDecl name bType = let (strict, typ) = mapBangType bType+ in (mapName name, strict, typ)++mapBangType :: H.BangType -> StrictType+mapBangType (H.BangedTy t) = (IsStrict, mapTypeToTH t)+mapBangType (H.UnBangedTy t) = (NotStrict, mapTypeToTH t)+mapBangType (H.UnpackedTy _) = error "No support for unboxed type (via UNPACK pragma) in Template Haskell"+++mapExpToTH :: H.Exp -> Exp+mapExpToTH (H.Var name) = VarE (mapQName name)+mapExpToTH (H.IPVar _) = error "No implicit parameter support"+mapExpToTH (H.Con name) = ConE (mapQName name)+mapExpToTH (H.Lit lit) = LitE (mapLitToTH lit)+mapExpToTH (H.InfixApp l op r) = InfixE (Just $ mapExpToTH l) (mapQOpToTH op) (Just $ mapExpToTH r)+mapExpToTH (H.App l r) = (mapExpToTH l) `AppE` (mapExpToTH r)+mapExpToTH (H.NegApp o) = AppE (VarE 'negate) (mapExpToTH o)+mapExpToTH (H.Lambda _ pat e) = LamE (map mapPatToTH pat) (mapExpToTH e)+mapExpToTH (H.Let bs e) = LetE (mapBinds bs) (mapExpToTH e)+mapExpToTH (H.If e t f) = CondE (mapExpToTH e) (mapExpToTH t) (mapExpToTH f)+mapExpToTH (H.Case e ms) = CaseE (mapExpToTH e) (map mapAlt ms)+mapExpToTH (H.Do s) = DoE (map mapStmt s)+mapExpToTH (H.MDo _) = error "No support for mdo expressions"+mapExpToTH (H.Tuple es) = TupE (map mapExpToTH es)+mapExpToTH (H.TupleSection _) = error "Tuple sections currently not supported by template haskell"+mapExpToTH (H.List es) = ListE (map mapExpToTH es)+mapExpToTH (H.Paren e) = mapExpToTH e+mapExpToTH (H.LeftSection e o) = InfixE (Just (mapExpToTH e)) (mapQOpToTH o) Nothing+mapExpToTH (H.RightSection o e) = InfixE Nothing (mapQOpToTH o) (Just (mapExpToTH e))+mapExpToTH (H.RecConstr n fs) = RecConE (mapQName n) (map mapFieldUpdate fs)+mapExpToTH (H.RecUpdate e fs) = RecUpdE (mapExpToTH e) (map mapFieldUpdate fs)+mapExpToTH (H.EnumFrom e) = ArithSeqE (FromR (mapExpToTH e))+mapExpToTH (H.EnumFromTo x y) = ArithSeqE (FromToR (mapExpToTH x) (mapExpToTH y))+mapExpToTH (H.EnumFromThen x y) = ArithSeqE (FromThenR (mapExpToTH x) (mapExpToTH y))+mapExpToTH (H.EnumFromThenTo x y z) = ArithSeqE (FromThenToR (mapExpToTH x) (mapExpToTH y) (mapExpToTH z))+mapExpToTH (H.ListComp e qs) = CompE (map mapQualStmt qs ++ [NoBindS $ mapExpToTH e])+mapExpToTH (H.ParComp _ _) = error "No support for parallel list comprehensions in Template Haskell"+mapExpToTH (H.ExpTypeSig _ e t) = SigE (mapExpToTH e) (mapTypeToTH t)+mapExpToTH (H.VarQuote _) = error "Template Haskell brackets cannot be nested (without intervening splices)"+mapExpToTH (H.TypQuote _) = error "Template Haskell brackets cannot be nested (without intervening splices)"+mapExpToTH (H.BracketExp _) = error "Template Haskell brackets cannot be nested (without intervening splices)"+mapExpToTH (H.SpliceExp _) = error "Template Haskell brackets cannot be nested (without intervening splices)"+mapExpToTH (H.QuasiQuote _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)"+mapExpToTH (H.XTag _ _ _ _ _) = error "No support for XML extension in Template Haskell"+mapExpToTH (H.XETag _ _ _ _) = error "No support for XML extension in Template Haskell"+mapExpToTH (H.XPcdata _) = error "No support for XML extension in Template Haskell"+mapExpToTH (H.XExpTag _) = error "No support for XML extension in Template Haskell"+mapExpToTH (H.XChildTag _ _) = error "No support for XML extension in Template Haskell"+mapExpToTH (H.CorePragma _ _) = error "No support for pragmas in Template Haskell"+mapExpToTH (H.SCCPragma _ _) = error "No support for pragmas in Template Haskell"+mapExpToTH (H.GenPragma _ _ _ _) = error "No support for pragmas in Template Haskell"+mapExpToTH (H.Proc _ _ _) = error "No support for arrows 'proc' in Template Haskell"+mapExpToTH (H.LeftArrApp _ _) = error "No support for left arrow application in Template Haskell"+mapExpToTH (H.RightArrApp _ _) = error "No support for right arrow application in Template Haskell"+mapExpToTH (H.LeftArrHighApp _ _) = error "No support for higher-order left arrow application in Template Haskell"+mapExpToTH (H.RightArrHighApp _ _) = error "No support for higher-order right arrow application in Template Haskell"+++mapQualStmt :: H.QualStmt -> Stmt+mapQualStmt (H.QualStmt stmt) = mapStmt stmt+mapQualStmt _ = error "No support for SQL-like generalized list comprehensions (not supported by Template Haskell)"++mapFieldUpdate :: H.FieldUpdate -> FieldExp+mapFieldUpdate (H.FieldUpdate n e) = (mapQName n, mapExpToTH e)+mapFieldUpdate (H.FieldPun _) = error "No support for field puns in update expressions"+mapFieldUpdate (H.FieldWildcard ) = error "No support for field wildcards in update expressions"++mapAlt :: H.Alt -> Match+mapAlt (H.Alt _ p g bs) = Match (mapPatToTH p) (mapGuard g) (mapBinds bs)++mapGuard :: H.GuardedAlts -> Body+mapGuard (H.UnGuardedAlt e) = NormalB (mapExpToTH e)+mapGuard (H.GuardedAlts gs) =+ GuardedB (map mapGAlt gs)+ where+ mapGAlt (H.GuardedAlt _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e)++mapStmt :: H.Stmt -> Stmt+mapStmt (H.Generator _ p e) = BindS (mapPatToTH p) (mapExpToTH e)+mapStmt (H.Qualifier e) = NoBindS (mapExpToTH e)+mapStmt (H.LetStmt bs) = LetS (mapBinds bs)+mapStmt (H.RecStmt rs) = ParS [map mapStmt rs]++mapBinds :: H.Binds -> [Dec]+mapBinds (H.BDecls decls) = concatMap mapDecl decls+mapBinds (H.IPBinds _) = error "No support for implicit parameter bindings"++mapQOpToTH :: H.QOp -> Exp+mapQOpToTH (H.QVarOp name) = VarE (mapQName name)+mapQOpToTH (H.QConOp name) = ConE (mapQName name)++{-+mapQOpToTHT :: H.QOp -> Type+mapQOpToTHT (H.QVarOp name) = VarT (mapQName name)+mapQOpToTHT (H.QConOp name) = ConT (mapQName name)+-}++mapPatToTH :: H.Pat -> Pat+mapPatToTH (H.PVar name) = VarP (mapName name)+mapPatToTH (H.PLit lit) = LitP (mapLitToTH lit)+mapPatToTH (H.PNeg _) = error "What?! (http://trac.haskell.org/haskell-src-exts/ticket/209)"+mapPatToTH (H.PNPlusK _ _) = error "No support for N+K patterns"+mapPatToTH (H.PInfixApp l n r) = InfixP (mapPatToTH l) (mapQName n) (mapPatToTH r)+mapPatToTH (H.PApp n p) = ConP (mapQName n) (map mapPatToTH p)+mapPatToTH (H.PTuple p) = TupP (map mapPatToTH p)+mapPatToTH (H.PList p) = ListP (map mapPatToTH p)+mapPatToTH (H.PParen p) = mapPatToTH p+mapPatToTH (H.PRec n pf) = RecP (mapQName n) (map mapPatFieldToTH pf)+mapPatToTH (H.PAsPat n p) = AsP (mapName n) (mapPatToTH p)+mapPatToTH (H.PWildCard ) = WildP+mapPatToTH (H.PIrrPat p) = TildeP (mapPatToTH p)+mapPatToTH (H.PatTypeSig _ p t) = SigP (mapPatToTH p) (mapTypeToTH t)+mapPatToTH (H.PViewPat _ _) = error "No support for view patterns"+mapPatToTH (H.PRPat _) = error "I don't know what a PR pattern is"+mapPatToTH (H.PXTag _ _ _ _ _) = error "No support for XML"+mapPatToTH (H.PXETag _ _ _ _) = error "No support for XML"+mapPatToTH (H.PXPcdata _) = error "No support for XML"+mapPatToTH (H.PXPatTag _) = error "No support for XML"+mapPatToTH (H.PXRPats _) = error "No support for XML"+mapPatToTH (H.PExplTypeArg _ _) = error "No support for explicit type arguments"+mapPatToTH (H.PQuasiQuote _ _) = error "No support for quasi-quotation"+mapPatToTH (H.PBangPat _) = error "No support for bang patterns"++mapTypeToTH :: H.Type -> Type+mapTypeToTH (H.TyForall vb ctx t) = ForallT (maybe [] (map mapTypeBind) vb) (mapContext ctx) (mapTypeToTH t)+mapTypeToTH (H.TyFun l r) = AppT (AppT ArrowT (mapTypeToTH l)) (mapTypeToTH r)+mapTypeToTH (H.TyTuple _ ts) = foldl AppT (TupleT (length ts)) (map mapTypeToTH ts)+mapTypeToTH (H.TyList t) = AppT ListT (mapTypeToTH t)+mapTypeToTH (H.TyApp l r) = AppT (mapTypeToTH l) (mapTypeToTH r)+mapTypeToTH (H.TyVar v) = VarT (mapName v)+mapTypeToTH (H.TyCon c) = ConT (mapQName c)+mapTypeToTH (H.TyParen t) = mapTypeToTH t+mapTypeToTH (H.TyInfix l op r) = AppT (AppT (ConT $ mapQName op) (mapTypeToTH l)) (mapTypeToTH r)+mapTypeToTH (H.TyKind _ _) = error "No support for types with explicit type kinds"++mapTypeBind :: H.TyVarBind -> TyVarBndr+mapTypeBind (H.KindedVar n k) = KindedTV (mapName n) (mapKind k)+mapTypeBind (H.UnkindedVar n) = PlainTV (mapName n)++mapKind :: H.Kind -> Kind+mapKind (H.KindStar ) = StarK+mapKind (H.KindBang ) = error "No support for bang-kinds"+mapKind (H.KindFn x y) = ArrowK (mapKind x) (mapKind y)+mapKind (H.KindParen k) = mapKind k+mapKind (H.KindVar _) = error "No support for kind variables"++mapContext :: H.Context -> Cxt+mapContext =+ map mapAssert+ where+ mapAssert (H.ClassA q ts) = ClassP (mapQName q) (map mapTypeToTH ts)+ mapAssert (H.InfixA x q y) = ClassP (mapQName q) [mapTypeToTH x, mapTypeToTH y]+ mapAssert (H.IParam _ _) = error "No support for implicit parameter assertion"+ mapAssert (H.EqualP x y) = EqualP (mapTypeToTH x) (mapTypeToTH y)++mapPatFieldToTH :: H.PatField -> FieldPat+mapPatFieldToTH (H.PFieldPat name pat) = (mapQName name, mapPatToTH pat)+mapPatFieldToTH (H.PFieldPun _) = error "field puns not yet supported"+mapPatFieldToTH (H.PFieldWildcard ) = (mkName "", WildP)++mapLitToTH :: H.Literal -> Lit+mapLitToTH (H.Char c) = CharL c+mapLitToTH (H.String s) = StringL s+mapLitToTH (H.Int i) = IntegerL i+mapLitToTH (H.Frac r) = RationalL r+mapLitToTH (H.PrimInt i) = IntPrimL i+mapLitToTH (H.PrimWord w) = WordPrimL w+mapLitToTH (H.PrimFloat f) = FloatPrimL f+mapLitToTH (H.PrimDouble d) = DoublePrimL d+mapLitToTH (H.PrimChar c) = CharL c+mapLitToTH (H.PrimString s) = StringPrimL s++++-- Local Variables:+-- mode : Haskell+-- fill-column : 120+-- default-justification : left+-- End:
+ src/Snap/Snaplet/MongoDB/Template.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+++module Snap.Snaplet.MongoDB.Template+ ( asMongoEntity+ , useDefaults+ , setCollectionName+ , forConstructor+ , ConstructorOp+ , setConstructorName+ , renameFields+ , assocFieldNames+ , indexedFieldName+ , setFieldReadOnly+ , asMongoValue+ , encodedViaShow+ ) where++import Control.Applicative+import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Writer+import qualified Data.Bson as BSON+import Data.Char (toUpper, toLower)+import Data.List (find)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH.Syntax hiding (lift)+import Snap.Snaplet.MongoDB.MongoValue+import Snap.Snaplet.MongoDB.MongoEntity+++-- Represents a field declaration from the type we are to store.+data FieldDecl = -- A field in a record data type constructor.+ FieldDecl { fieldName :: Name -- The actual name of the field.+ , fieldSimpleName :: String -- The simple name of the field, as stored in the document (can be changed).+ , fieldType :: Type+ , fieldReadOnly :: Bool -- If 'True', the field will not be output by the 'toDocument' function.+ }+ -- Represents a field in a 'NormalC' data type constructor.+ | SimpleFieldDecl { simpleFieldName :: String+ , simpleFieldType :: Type }++-- Represents a constructor to a data type. We blend both 'NormalC' and 'RecordC' data type constructors into this type.+data Constructor = Constructor { constrName :: Name -- The actual name of the constructor.+ , constrSimpleName :: String -- The simple name of the constructor, as stored in the _type field in the document (can be changed).+ , constrBody :: [FieldDecl]+ }++-- The environment in which our template builder lives. This is actually used as _state_, but whatever.+data TemplateEnv = TemplateEnv { envTypeName :: Name -- The name of the type we are generating a MongoEntity instance for.+ , envSimpleTypeName :: String -- The simple name of the type.+ , envCollectionName :: String -- The name of the collection to which we are to store this type.+ , envEncodedViaShow :: Bool -- Is the 'MongoValue' instance encoded via Show/Read rather than toDocument/fromDocument?+ , envConstructors :: [Constructor]+ }++type EndoFunctor a = a -> a+type TemplateGen = StateT TemplateEnv (WriterT (EndoFunctor [Dec]) Q)+++-- | This function is used to indicate to 'asMongoEntity' and 'asMongoValue' that the default behaviour is to be used.+useDefaults :: TemplateGen ()+useDefaults = return ()++-- | This function generates an instance of the 'MongoEntity' and 'MongoValue' type classes for the specified type.+asMongoEntity :: Name -> TemplateGen () -> Q [Dec]+asMongoEntity typeName actions =+ runTemplateGen typeName (actions >> genEntityInstance >> genValueInstance)++-- | This function generates an instance of the 'MongoValue' type class for the given type. If the type is to be encoded+-- via 'show' and 'read', then a 'MongoEntity' instance is /not/ created; otherwise one will be.+asMongoValue :: Name -> TemplateGen () -> Q [Dec]+asMongoValue typeName actions = do+ runTemplateGen typeName $ do+ actions+ viaShow <- gets envEncodedViaShow+ if viaShow then genValueViaShowInstance else (genEntityInstance >> genValueInstance)+++-- | Set the name of the collection to which the type is to be stored. By default, the name of the collection is the+-- same as the name of the type.+setCollectionName :: String -> TemplateGen ()+setCollectionName newName =+ modify (\s -> s { envCollectionName = newName })++-- | Sets whether the 'MongoValue' instance for the type should be encoded via 'read' and 'show' rather than+-- 'fromDocument' and 'toDocument'.+encodedViaShow :: TemplateGen ()+encodedViaShow =+ modify (\s -> s { envEncodedViaShow = True })++-- | Operations over constructors live in the 'ConstructorOp' monad.+type ConstructorOp = StateT Constructor TemplateGen++-- | For @foConstructor name ops@, perform @ops@ for the constructor matching @name@. This allows us to change the name+-- of the constructor stored in the @_type@ field, and alter the behaviour of individual fields.+forConstructor :: Name -> ConstructorOp () -> TemplateGen ()+forConstructor name f = do+ constrs <- dConstr name f =<< gets envConstructors+ modify (\s -> s { envConstructors = constrs })+ where+ dConstr _ _ [] = return []+ dConstr name f (x : xs)+ | constrName x == name = do+ (_, x') <- runStateT f x+ return (x' : xs)+ | otherwise = do+ xs' <- dConstr name f xs+ return (x : xs')++-- | Set the name stored in the @_type@ field of the document for the current constructor.+setConstructorName :: String -> ConstructorOp ()+setConstructorName newName = do+ modify (\c -> c { constrSimpleName = newName })++-- | Set the field with the specified name to read only. This will mean that the 'toDocument' function will not output+-- this field. This means that the field's value will not be written to the document.+setFieldReadOnly :: Name -> ConstructorOp ()+setFieldReadOnly name =+ modify (\c -> c { constrBody = dField name (constrBody c) })+ where+ dField _ [] = []+ dField name (f : fs)+ | fieldName f == name =+ f { fieldReadOnly = True } : fs+ | otherwise =+ f : dField name fs++-- | Change the names of a number of fields. The default behaviour is for the fields in the document to have the same+-- name as the fields in the record type constructor.+assocFieldNames :: [(Name, String)] -> ConstructorOp ()+assocFieldNames assocs =+ modify (\c -> c { constrBody = dField (constrBody c) })+ where+ dField [] = []+ dField (field : fields) =+ case field of+ FieldDecl name _ _ _ ->+ (maybe field (\newName -> field { fieldSimpleName = newName }) $ lookup name assocs) : dField fields+ SimpleFieldDecl name _ ->+ let name' = mkName name in (maybe field (\newName -> field { simpleFieldName = newName }) $ lookup name' assocs) : dField fields++-- | Renames fields in the order they are found in the type constructor.+renameFields :: [String] -> ConstructorOp ()+renameFields newNames =+ modify (\c -> c { constrBody = zipWith renameField newNames (constrBody c) })+ where+ renameField newName (FieldDecl fn _ ft ro) = FieldDecl fn newName ft ro+ renameField newName (SimpleFieldDecl _ ft) = SimpleFieldDecl newName ft+++indexedFieldName :: Int -> Name+indexedFieldName = mkName . ("field" ++) . show+++runTemplateGen :: Name -> TemplateGen () -> Q [Dec]+runTemplateGen typeName actions = do+ (simpleName, constructors) <- getSimpleNameAndConstrs typeName+ + let env = TemplateEnv { envTypeName = typeName+ , envSimpleTypeName = simpleName+ , envCollectionName = simpleName+ , envEncodedViaShow = False+ , envConstructors = buildConstructors constructors+ }+ (_, decls) <- runWriterT (runStateT actions env)+ return $ decls []+++inner :: TemplateGen a -> TemplateGen (a, [Dec])+inner action = do+ state <- get+ ((result, newState), decls) <- lift . lift $ runWriterT (runStateT action state)+ put newState+ return (result, decls [])+++getSimpleNameAndConstrs :: Name -> Q (String, [Con])+getSimpleNameAndConstrs typeName = do+ typeInfo <- reify typeName+ case typeInfo of+ TyConI tyCon ->+ case tyCon of+ DataD _ n _ c _ -> return (dropPrefix $ show n, c )+ NewtypeD _ n _ c _ -> return (dropPrefix $ show n, [c])+ _ -> error $ "No able to handle `" ++ show typeName ++ "'; not a data or newtype"+ _ -> error $ "Not able to handle `" ++ show typeName ++ "'; not a type constructor"+++buildConstructors :: [Con] -> [Constructor]+buildConstructors =+ map buildConstructor+ where+ buildConstructor :: Con -> Constructor+ buildConstructor (NormalC name types) =+ Constructor { constrName = name+ , constrSimpleName = dropPrefix $ show name+ , constrBody = map (\(n, (_, t)) -> SimpleFieldDecl { simpleFieldName = "field" ++ show n, simpleFieldType = t }) $ zip [1 ..] types+ }+ buildConstructor (RecC name fields) =+ Constructor { constrName = name+ , constrSimpleName = dropPrefix $ show name+ , constrBody = map (\(n, _, t) ->+ let (r, n') = if ((dropPrefix . show $ n) == ((uncapitalize . dropPrefix . show $ name) ++ "Id"))+ then (True, "_id")+ else (False, dropPrefix $ show n)+ in FieldDecl { fieldName = n+ , fieldSimpleName = n'+ , fieldType = t+ , fieldReadOnly = r+ })+ fields+ }+ buildConstructor _ = error "Cannot build constructor for non-record or non-normal data type constructor"+++-- Emits a declaration in the underlying writer monad.+emitDecl :: Dec -> TemplateGen ()+emitDecl = lift . tell . (:)++-- Generate the key newtype and the 'fromKey' and 'toKey' functions for the specified type. For a given type MyType, we+-- generate a newtype with the following definition:+--+-- newtype Key MyType = MyTypeId { unMyTypeId :: ObjectId }+-- deriving (Show)+--+-- The two functions 'toKey' and 'fromKey' are simply aliases for constructing and deconstructing this type:+--+-- toKey = MyTypeId+-- fromKey = unMyTypeId+--+genKeyDecls :: TemplateGen ()+genKeyDecls = do+ name <- gets envTypeName+ name' <- gets envSimpleTypeName+ emitDecl $ NewtypeInstD [] ''Key [ConT name]+ (RecC (mkName $ name' ++ "Id")+ [ (mkName $ "un" ++ name' ++ "Id", NotStrict, ConT ''ObjectId) ])+ [ ''Eq ]+ emitDecl $ FunD (mkName "toKey")+ [ Clause [] (NormalB . ConE . mkName $ name' ++ "Id") [] ]+ emitDecl $ FunD (mkName "fromKey")+ [ Clause [] (NormalB . VarE . mkName $ "un" ++ name' ++ "Id") []]+++genDocumentDecls :: TemplateGen ()+genDocumentDecls = do+ name <- gets envTypeName+ name' <- gets envSimpleTypeName+ emitDecl $ NewtypeInstD [] ''Document [ConT name]+ (RecC (mkName $ name' ++ "Document")+ [ (mkName $ "un" ++ name' ++ "Document", NotStrict, ConT ''BSON.Document) ])+ []+ emitDecl $ FunD (mkName "toDocument")+ [ Clause [] (NormalB . ConE . mkName $ name' ++ "Document") [] ]+ emitDecl $ FunD (mkName "fromDocument")+ [ Clause [] (NormalB . VarE . mkName $ "un" ++ name' ++ "Document") [] ]+++genCollNameDecl :: TemplateGen ()+genCollNameDecl = do+ cName <- gets envCollectionName+ emitDecl $ FunD (mkName "collectionName")+ [ Clause [WildP] (NormalB $ LitE $ StringL cName) [] ]+++-- This function generates the filter declaration. The filter type instance has the following form:+--+-- data Filter MyType = MyFieldA Int | MyFieldB String | ...+--+-- Where each field in MyType has a constructor in the (Filter MyType) data type.+genFilterDecl :: TemplateGen ()+genFilterDecl = do+ name <- gets envTypeName+ constrs <- gets envConstructors+ let cons = catMaybes $ concatMap (\c -> map (buildFieldCon (dropPrefix . show $ constrName c)) (constrBody c)) constrs+ emitDecl $ DataInstD [] ''Filter [ConT name]+ (map fst cons)+ []+ let clauses = map (\((NormalC name _), fName) ->+ Clause [ConP name [WildP]] (NormalB . LitE . StringL . dropPrefix . show $ fName) []) cons+ if not . null $ clauses+ then emitDecl $ FunD (mkName "filterFieldName") clauses+ else emitDecl $ FunD (mkName "filterFieldName") [Clause [WildP] (NormalB ((VarE 'error) `AppE` (LitE $ StringL "no filters can be defined"))) []]+ where+ buildFieldCon :: String -> FieldDecl -> Maybe (Con, Name)+ buildFieldCon constrName (FieldDecl fieldName simpleName fType _) =+ if ((dropPrefix . show $ fieldName) == (uncapitalize constrName ++ "Id")) ||+ (simpleName == "_id") + then Nothing+ else Just (NormalC (mkName . capitalize . dropPrefix . show $ fieldName) [(NotStrict, fType)], mkName simpleName)+ buildFieldCon _ (SimpleFieldDecl _ _) =+ Nothing++ ++-- This function generates the 'encodeDocument' function for the 'MongoEntity' instance. The 'encodeDocument' function+-- generates a Document from an instance of the type. For example, given the type:+--+-- data A = A { fieldA :: Int+-- , fieldB :: String+-- }+-- | B { fieldC :: String+-- , fieldD :: Int+-- }+--+-- A document will have one of the following forms:+--+-- { _type: "A", fieldA: 123, fieldB: "hello" }+-- { _type: "B", fieldA: "world", fieldB: 456 }+--+-- The Haskell code to generate this will be equivalent to:+--+-- encodeDocument (A field1 field2) = toDocument [ "_type" := toValue "A", "fieldA" := toValue field1, "fieldB" := toValue field2 ]+-- encodeDocument (B field1 field2) = toDocument [ "_type" := toValue "B", "fieldC" := toValue field1, "fieldD" := toValue field2 ]+--+--+-- Note: The extra field '_type' is stored in the document such that we know which constructor to use when we load the+-- document back into Haskell.+--+-- Note: A field will not be written to the document if it has been set 'readOnly'.+--+-- Note: A field will not be written to the document if it matches as the ID of the document. A field is recognised as+-- the ID of the document if it's name matches the constructor of the type, followed by "Id". For example, for a data+-- type constructor 'MyType', a field with the name 'myTypeId' will be assumed to be the ID field.+--+genEncodeDocument :: TemplateGen ()+genEncodeDocument = do+ constrs <- gets envConstructors+ emitDecl $ FunD (mkName "encodeDocument") $ map buildClause constrs+ where+ buildClause :: Constructor -> Clause+ buildClause constr =+-- let patNames = map (mkName . ("field" ++) . show . fst) $ zip [1 ..] (constrBody constr)+ let fn (FieldDecl _ n _ _) = n+ fn (SimpleFieldDecl n _) = n+ patNames = map (mkName . ('_' :) . fn) (constrBody constr)+ setType = InfixE (Just . LitE $ StringL "_type")+ (ConE '(:=))+ (Just ((VarE 'toValue) `AppE` ((LitE $ StringL (constrSimpleName constr)) `SigE` (ConT ''Text))))+ setFields = catMaybes (map (genField (dropPrefix . show $ constrName constr)) (zip patNames (constrBody constr)))+ in Clause [ConP (constrName constr) (map VarP patNames)]+ (NormalB $ ((VarE 'toDocument) `AppE` (ListE (setType : setFields))))+ []+ + genField :: String -> (Name, FieldDecl) -> Maybe Exp+ genField constrName (patName, SimpleFieldDecl fieldName _) =+ Just (InfixE (Just . LitE . StringL $ fieldName) (ConE '(:=)) (Just ((VarE 'toValue) `AppE` (VarE patName))))+ genField constrName (patName, FieldDecl fieldName simpleName _ readOnly) =+ if readOnly ||+ ((dropPrefix . show $ fieldName) == (uncapitalize constrName ++ "Id")) ||+ (simpleName == "_id")+ then Nothing+ else Just (InfixE (Just . LitE . StringL $ simpleName) (ConE '(:=)) (Just ((VarE 'toValue) `AppE` (VarE patName))))++{-+decodeDocument doc' = do+ let doc = fromDocument doc'+ typ <- lookupThrow "_type" doc+ case typ of+ "A" -> A <$> lookupThrow "fieldA" doc <*> lookupThrow "fieldB" doc+ other -> throwError $ "Unknown type constructor '" ++ other ++ "' found in collection for data type '" ++ "A"+-}++genDecodeDocument :: TemplateGen ()+genDecodeDocument = do+ name <- gets envTypeName+ cName <- gets envCollectionName+ constrs <- gets envConstructors+ let doc' = mkName "doc'"+ emitDecl $ FunD (mkName "decodeDocument") $+ [ Clause [VarP doc'] (NormalB $ buildBody name cName doc' constrs) [] ]+ where+ buildBody :: Name -> String -> Name -> [Constructor] -> Exp+ buildBody name cName doc' constrs =+ let typ = mkName "typ"+ other = mkName "other"+ doc = mkName "doc"+ in DoE [ LetS [ ValD (VarP doc) (NormalB ((VarE 'fromDocument) `AppE` (VarE doc'))) [] ]+ , BindS (VarP typ) (((VarE 'lookupThrow) `AppE` (LitE $ StringL "_type")) `AppE` (VarE doc))+ , NoBindS $ CaseE (VarE typ) (map (buildMatch doc) constrs ++ [ Match (VarP other)+ (NormalB $ ((VarE 'throwError) `AppE`+ ((VarE 'concat) `AppE`+ ListE [ LitE $ StringL "Unknown type constructor '"+ , ((VarE 'T.unpack) `AppE` (VarE other))+ , LitE $ StringL "' found in collection for data type '"+ , LitE $ StringL (dropPrefix $ show name)+ , LitE $ StringL "' ("+ , LitE $ StringL cName + , LitE $ StringL ")"]))) []]) ]++ buildMatch :: Name -> Constructor -> Match+ buildMatch doc constr =+ let body = if null (constrBody constr)+ then ((VarE 'return) `AppE` (ConE (constrName constr)))+ else foldl (genFieldApp doc)+ (InfixE (Just (ConE $ constrName constr))+ (VarE '(<$>))+ (Just (genFieldLookup doc $ head (constrBody constr))))+ (tail (constrBody constr))+ in Match (LitP $ StringL $ constrSimpleName constr) (NormalB $ body) []++ genFieldApp :: Name -> Exp -> FieldDecl -> Exp+ genFieldApp doc lhs fieldDecl =+ InfixE (Just lhs)+ (VarE '(<*>))+ (Just $ genFieldLookup doc fieldDecl)++ genFieldLookup :: Name -> FieldDecl -> Exp+ genFieldLookup doc (SimpleFieldDecl simpleName _) =+ ((VarE 'lookupThrow) `AppE` (LitE $ StringL simpleName)) `AppE` (VarE doc)+ genFieldLookup doc (FieldDecl _ simpleName _ _) =+ ((VarE 'lookupThrow) `AppE` (LitE $ StringL simpleName)) `AppE` (VarE doc)+++genEntityInstance :: TemplateGen ()+genEntityInstance = do+ name <- gets envTypeName+ (_, decls) <- inner $ do+ genKeyDecls+ genDocumentDecls+ genCollNameDecl+ genFilterDecl+ genEncodeDocument+ genDecodeDocument+ emitDecl $ InstanceD [] (ConT ''MongoEntity `AppT` ConT name) decls+++genValueViaShowInstance :: TemplateGen ()+genValueViaShowInstance = do+ name <- gets envTypeName+ emitDecl $ InstanceD [] (ConT ''MongoValue `AppT` ConT name)+ [ FunD (mkName "toValue")+ [ Clause []+ (NormalB (InfixE (Just (VarE 'toValue)) (VarE '(.)) (Just $ InfixE (Just (VarE 'T.pack)) (VarE '(.)) (Just (VarE 'show)))))+ []+ ]+ , FunD (mkName "fromValue")+ [ Clause [VarP (mkName "v")]+ (NormalB (InfixE (Just (InfixE (Just (VarE 'return)) (VarE '(.))+ (Just $ InfixE (Just (VarE 'read)) (VarE '(.)) (Just (VarE 'T.unpack)))))+ (VarE '(=<<))+ (Just (AppE (VarE 'fromValue) (VarE (mkName "v"))))))+ []+ ]+ ]+ ++genValueInstance :: TemplateGen ()+genValueInstance = do+ name <- gets envTypeName+ let x = InfixE (Just $ VarE 'toValue) (VarE '(.)) (Just $ InfixE (Just $ VarE 'fromDocument) (VarE '(.)) (Just $ VarE 'encodeDocument))+ let y d = InfixE (Just $ InfixE (Just $ VarE 'decodeDocument) (VarE '(.)) (Just $ VarE 'toDocument)) (VarE '($)) (Just d)+ let doc = mkName "doc"+ val = mkName "val"+ emitDecl $ InstanceD [] (ConT ''MongoValue `AppT` ConT name)+ [ FunD (mkName "toValue")+ [ Clause [] (NormalB x) [] ]+ , FunD (mkName "fromValue")+ [ --Clause [ConP 'Doc [VarP doc]] (NormalB ((VarE 'fromDocument) `AppE` (VarE doc))) []+ Clause [ConP 'Doc [VarP doc]] (NormalB $ y (VarE doc)) []+ , Clause [VarP val] (NormalB (((VarE 'expected) `AppE` (LitE $ StringL "Document")) `AppE` (VarE val))) []+ ]+ ]+ ++++dropPrefix :: String -> String+dropPrefix = reverse . takeWhile (/= '.') . reverse++capitalize :: String -> String+capitalize [] = []+capitalize (c : cs) = toUpper c : cs++uncapitalize :: String -> String+uncapitalize [] = []+uncapitalize (c : cs) = toLower c : cs+++-- Local Variables:+-- mode : Haskell+-- fill-column : 120+-- default-justification : left+-- End: