persistent (empty) → 0.0.0
raw patch · 7 files changed
+1047/−0 lines, 7 filesdep +MonadCatchIO-transformersdep +basedep +bytestringsetup-changed
Dependencies added: MonadCatchIO-transformers, base, bytestring, hamlet, template-haskell, text, time, utf8-string, web-routes-quasi
Files
- Database/Persist.hs +244/−0
- Database/Persist/GenericSql.hs +356/−0
- Database/Persist/Helper.hs +326/−0
- Database/Persist/Quasi.hs +56/−0
- LICENSE +25/−0
- Setup.lhs +7/−0
- persistent.cabal +33/−0
+ Database/Persist.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-}++-- | This defines the API for performing database actions. There are two levels+-- to this API: dealing with fields, and dealing with entities. In SQL, a field+-- corresponds to a column, and should be a single, non-composite value. An+-- entity corresponds to a SQL table. In other words: An entity is a+-- collection of fields.+module Database.Persist+ ( -- * Fields+ PersistValue (..)+ , SqlType (..)+ , PersistField (..)+ -- * Entities+ , PersistEntity (..)+ ) where++import Data.Time (Day, TimeOfDay, UTCTime)+import Data.ByteString.Char8 (ByteString, unpack)+import qualified Data.ByteString.UTF8 as BSU+import Control.Applicative+import Data.Typeable (Typeable)+import Data.Int (Int64)+import Text.Hamlet+import qualified Data.Text as T+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)++-- | A raw value which can be stored in any backend and can be marshalled to+-- and from a 'PersistField'.+data PersistValue = PersistString String+ | PersistByteString ByteString+ | PersistInt64 Int64+ | PersistDouble Double+ | PersistBool Bool+ | PersistDay Day+ | PersistTimeOfDay TimeOfDay+ | PersistUTCTime UTCTime+ | PersistNull+ deriving (Show, Read, Eq, Typeable)++-- | A SQL data type. Naming attempts to reflect the underlying Haskell+-- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may+-- have different translations for these types.+data SqlType = SqlString+ | SqlInteger+ | SqlReal+ | SqlBool+ | SqlDay+ | SqlTime+ | SqlDayTime+ | SqlBlob+ deriving (Show, Read, Eq, Typeable)++-- | A value which can be marshalled to and from a 'PersistValue'.+class PersistField a where+ toPersistValue :: a -> PersistValue+ fromPersistValue :: PersistValue -> Either String a+ sqlType :: a -> SqlType+ isNullable :: a -> Bool+ isNullable _ = False++instance PersistField String where+ toPersistValue = PersistString+ fromPersistValue (PersistString s) = Right s+ fromPersistValue (PersistByteString bs) = Right $ BSU.toString bs+ fromPersistValue (PersistInt64 i) = Right $ show i+ fromPersistValue (PersistDouble d) = Right $ show d+ fromPersistValue (PersistDay d) = Right $ show d+ fromPersistValue (PersistTimeOfDay d) = Right $ show d+ fromPersistValue (PersistUTCTime d) = Right $ show d+ fromPersistValue PersistNull = Left "Unexpected null"+ fromPersistValue (PersistBool b) = Right $ show b+ sqlType _ = SqlString++instance PersistField ByteString where+ toPersistValue = PersistByteString+ fromPersistValue (PersistByteString bs) = Right bs+ fromPersistValue x = BSU.fromString <$> fromPersistValue x+ sqlType _ = SqlBlob++instance PersistField T.Text where+ toPersistValue = PersistString . T.unpack+ fromPersistValue = fmap T.pack . fromPersistValue+ sqlType _ = SqlString++instance PersistField (Html ()) where+ toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml+ fromPersistValue = fmap unsafeByteString . fromPersistValue+ sqlType _ = SqlString++instance PersistField Int where+ toPersistValue = PersistInt64 . fromIntegral+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ "Expected Integer, received: " ++ show x+ sqlType _ = SqlInteger++instance PersistField Int64 where+ toPersistValue = PersistInt64 . fromIntegral+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ "Expected Integer, received: " ++ show x+ sqlType _ = SqlInteger++instance PersistField Double where+ toPersistValue = PersistDouble+ fromPersistValue (PersistDouble d) = Right d+ fromPersistValue x = Left $ "Expected Double, received: " ++ show x+ sqlType _ = SqlReal++instance PersistField Bool where+ toPersistValue = PersistBool+ fromPersistValue (PersistBool b) = Right b+ fromPersistValue (PersistInt64 i) = Right $ i /= 0+ fromPersistValue x = Left $ "Expected Bool, received: " ++ show x+ sqlType _ = SqlBool++instance PersistField Day where+ toPersistValue = PersistDay+ fromPersistValue (PersistDay d) = Right d+ fromPersistValue x@(PersistString s) =+ case reads s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected Day, received " ++ show x+ fromPersistValue x@(PersistByteString s) =+ case reads $ unpack s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected Day, received " ++ show x+ fromPersistValue x = Left $ "Expected Day, received: " ++ show x+ sqlType _ = SqlDay++instance PersistField TimeOfDay where+ toPersistValue = PersistTimeOfDay+ fromPersistValue (PersistTimeOfDay d) = Right d+ fromPersistValue x@(PersistString s) =+ case reads s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected TimeOfDay, received " ++ show x+ fromPersistValue x@(PersistByteString s) =+ case reads $ unpack s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected TimeOfDay, received " ++ show x+ fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x+ sqlType _ = SqlTime++instance PersistField UTCTime where+ toPersistValue = PersistUTCTime+ fromPersistValue (PersistUTCTime d) = Right d+ fromPersistValue x@(PersistString s) =+ case reads s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected UTCTime, received " ++ show x+ fromPersistValue x@(PersistByteString s) =+ case reads $ unpack s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected UTCTime, received " ++ show x+ fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x+ sqlType _ = SqlDayTime++instance PersistField a => PersistField (Maybe a) where+ toPersistValue Nothing = PersistNull+ toPersistValue (Just a) = toPersistValue a+ fromPersistValue PersistNull = Right Nothing+ fromPersistValue x = fmap Just $ fromPersistValue x+ sqlType _ = sqlType (error "this is the problem" :: a)+ isNullable _ = True++-- | A single database entity. For example, if writing a blog application, a+-- blog entry would be an entry, containing fields such as title and content.+class PersistEntity val where+ -- | The monad transformer in which actions for this entity must occur. For+ -- example, entities declared to work with a sqlite backend would most+ -- likely use a ReaderT monad transformer holding onto a database+ -- connection.+ --+ -- By using a monad transformer here, users can allow arbitrary effects to+ -- exist in the underlying monad. For example, Yesod applications can embed+ -- a Handler monad here. The only restriction on that underlying monad is+ -- it must be an instance of 'MonadCatchIO'.+ type PersistMonad val :: (* -> *) -> * -> *++ -- | The unique identifier associated with this entity. In general, backends also define a type synonym for this, such that \"type MyEntityId = Key MyEntity\".+ data Key val+ -- | Fields which can be updated using the 'update' and 'updateWhere'+ -- functions.+ data Update val+ -- | Filters which are available for 'select', 'updateWhere' and+ -- 'deleteWhere'. Each filter constructor specifies the field being+ -- filtered on, the type of comparison applied (equals, not equals, etc)+ -- and the argument for the comparison.+ data Filter val+ -- | How you can sort the results of a 'select'.+ data Order val+ -- | Unique keys in existence on this entity.+ data Unique val++ -- | Prepare database for this entity, if necessary. In SQL, this creates+ -- values and indices if they don't exist. The first argument is not used,+ -- so you can used 'undefined'.+ initialize :: MonadCatchIO m => val -> (PersistMonad val) m ()++ -- | Create a new record in the database, returning the newly created+ -- identifier.+ insert :: MonadCatchIO m => val -> (PersistMonad val) m (Key val)++ -- | Replace the record in the database with the given key. Result is+ -- undefined if such a record does not exist.+ replace :: MonadCatchIO m => Key val -> val -> (PersistMonad val) m ()++ -- | Update individual fields on a specific record.+ update :: MonadCatchIO m => Key val -> [Update val]+ -> (PersistMonad val) m ()++ -- | Update individual fields on any record matching the given criterion.+ updateWhere :: MonadCatchIO m => [Filter val] -> [Update val]+ -> (PersistMonad val) m ()++ -- | Delete a specific record by identifier. Does nothing if record does+ -- not exist.+ delete :: MonadCatchIO m => Key val -> (PersistMonad val) m ()++ -- | Delete a specific record by unique key. Does nothing if no record+ -- matches.+ deleteBy :: MonadCatchIO m => Unique val -> (PersistMonad val) m ()++ -- | Delete all records matching the given criterion.+ deleteWhere :: MonadCatchIO m => [Filter val] -> (PersistMonad val) m ()++ -- | Get a record by identifier, if available.+ get :: MonadCatchIO m => Key val -> (PersistMonad val) m (Maybe val)++ -- | Get a record by unique key, if available. Returns also the identifier.+ getBy :: MonadCatchIO m => Unique val+ -> (PersistMonad val) m (Maybe (Key val, val))++ -- | Get all records matching the given criterion in the specified order.+ -- Returns also the identifiers.+ select :: MonadCatchIO m => [Filter val] -> [Order val]+ -> (PersistMonad val) m [(Key val, val)]
+ Database/Persist/GenericSql.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+-- | This is a helper module for creating SQL backends. Regular users do not+-- need to use this module.+module Database.Persist.GenericSql+ ( Int64+ , module Database.Persist.Helper+ , persist+ , deriveGenericSql+ , RowPopper+ , GenericSql (..)+ ) where++import Database.Persist (PersistEntity, Key, Order, Filter, Update,+ Unique, SqlType (..), PersistValue (..),+ PersistField (..))+import Database.Persist.Helper+import Language.Haskell.TH.Syntax hiding (lift)+import qualified Language.Haskell.TH.Syntax as TH+import Data.List (intercalate)+import Control.Monad (unless, liftM)+import Data.Int (Int64)+import Database.Persist.Quasi+import Control.Arrow (second)++data GenericSql m = GenericSql+ { gsWithStmt :: forall a.+ String -> [PersistValue] -> (RowPopper m -> m a) -> m a+ , gsExecute :: String -> [PersistValue] -> m ()+ , gsInsert :: String -> [String] -> [PersistValue] -> m Int64+ , gsEntityDefExists :: String -> m Bool+ , gsKeyType :: String+ }++type RowPopper m = m (Maybe [PersistValue])++deriveGenericSql :: Type -> Exp -> EntityDef -> Q [Dec]+deriveGenericSql monad gs t = do+ let name = entityName t+ let dt = dataTypeDec t++ fsv <- mkFromPersistValues t+ let sq =+ InstanceD [] (ConT ''FromPersistValues `AppT` ConT (mkName name))+ [ FunD (mkName "fromPersistValues") fsv+ ]++ let keysyn = TySynD (mkName $ name ++ "Id") [] $+ ConT ''Key `AppT` ConT (mkName name)++ t' <- TH.lift t+ let mkFun s e = FunD (mkName s) [Clause [] (NormalB $ e `AppE` t') []]++ let gs' = fmap (`AppE` gs)+ init' <- gs' [|initialize|]+ insert' <- gs' [|insert|]+ replace' <- gs' [|replace|]+ get' <- gs' [|get|]+ getBy' <- gs' [|getBy|]+ select' <- gs' [|select|]+ deleteWhere' <- gs' [|deleteWhere|]+ delete' <- gs' [|delete|]+ deleteBy' <- gs' [|deleteBy|]+ update' <- gs' [|update|]+ updateWhere' <- gs' [|updateWhere|]++ let inst =+ InstanceD+ []+ (ConT ''PersistEntity `AppT` ConT (mkName name))+ [ persistMonadTypeDec monad t+ , keyTypeDec (name ++ "Id") "Int64" t+ , filterTypeDec t+ , updateTypeDec t+ , orderTypeDec t+ , uniqueTypeDec t+ , mkFun "initialize" $ init'+ , mkFun "insert" $ insert'+ , mkFun "replace" $ replace'+ , mkFun "get" $ get'+ , mkFun "getBy" $ getBy'+ , mkFun "select" $ select'+ , mkFun "deleteWhere" $ deleteWhere'+ , mkFun "delete" $ delete'+ , mkFun "deleteBy" $ deleteBy'+ , mkFun "update" $ update'+ , mkFun "updateWhere" $ updateWhere'+ ]++ tops <- mkToPersistFields (ConT $ mkName name)+ [(name, length $ tableColumns t)]+ topsUn <- mkToPersistFields (ConT ''Unique `AppT` ConT (mkName name))+ $ map (\(x, y) -> (x, length y))+ $ entityUniques t++ return+ [ dt, sq, inst, keysyn, tops, topsUn+ , mkToFieldName (ConT ''Update `AppT` ConT (mkName name))+ $ map (\(s, _, _) -> (name ++ upperFirst s, s))+ $ entityUpdates t+ , mkPersistField (ConT ''Update `AppT` ConT (mkName name))+ $ map (\(s, _, _) -> name ++ upperFirst s) $ entityUpdates t+ , mkToFieldNames (ConT ''Unique `AppT` ConT (mkName name))+ $ entityUniques t+ , mkPersistField (ConT ''Filter `AppT` ConT (mkName name))+ $ map (\(x, _, _, y) -> name ++ upperFirst x ++ show y)+ $ entityFilters t+ , mkToFieldName (ConT ''Filter `AppT` ConT (mkName name))+ $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x))+ $ entityFilters t+ , mkToFilter (ConT ''Filter `AppT` ConT (mkName name))+ $ map (\(x, _, z, y) ->+ (name ++ upperFirst x ++ show y, y, z))+ $ entityFilters t+ , mkToFieldName (ConT ''Order `AppT` ConT (mkName name))+ $ map (\(x, y) -> (name ++ upperFirst x ++ y, x))+ $ entityOrders t+ , mkToOrder (ConT ''Order `AppT` ConT (mkName name))+ $ map (\(x, y) -> (name ++ upperFirst x ++ y, y))+ $ entityOrders t+ , mkHalfDefined (ConT $ mkName name) name $ length $ tableColumns t+ ]++initialize :: (ToPersistFields v, Monad m, HalfDefined v)+ => GenericSql m -> EntityDef -> v -> m ()+initialize gs t v = do+ doesExist <- gsEntityDefExists gs $ tableName t+ unless doesExist $ do+ let cols = zip (tableColumns t) $ toPersistFields+ $ halfDefined `asTypeOf` v+ let sql = "CREATE TABLE " ++ tableName t +++ "(id " ++ gsKeyType gs +++ concatMap go' cols ++ ")"+ gsExecute gs sql []+ mapM_ go $ tableUniques' t+ where+ go' ((colName, _, as), p) = concat+ [ ","+ , colName+ , " "+ , showSqlType $ sqlType p+ , if "null" `elem` as then " NULL" else " NOT NULL"+ ]+ go (index, fields) = do+ let sql = "CREATE UNIQUE INDEX " ++ index ++ " ON " +++ tableName t ++ "(" ++ intercalate "," fields ++ ")"+ gsExecute gs sql []+ showSqlType SqlString = "VARCHAR"+ showSqlType SqlInteger = "INTEGER"+ showSqlType SqlReal = "REAL"+ showSqlType SqlDay = "DATE"+ showSqlType SqlTime = "TIME"+ showSqlType SqlDayTime = "TIMESTAMP"+ showSqlType SqlBlob = "BLOB"+ showSqlType SqlBool = "BOOLEAN"++mkFromPersistValues :: EntityDef -> Q [Clause]+mkFromPersistValues t = do+ nothing <- [|Left "Invalid fromPersistValues input"|]+ let cons = ConE $ mkName $ entityName t+ xs <- mapM (const $ newName "x") $ entityColumns t+ fs <- [|fromPersistValue|]+ let xs' = map (AppE fs . VarE) xs+ let pat = ListP $ map VarP xs+ ap' <- [|apE|]+ just <- [|Right|]+ let cons' = just `AppE` cons+ return+ [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') []+ , Clause [WildP] (NormalB nothing) []+ ]+ where+ go ap' x y = InfixE (Just x) ap' (Just y)++insert :: (Monad m, ToPersistFields val, Num (Key val))+ => GenericSql m -> EntityDef -> val -> m (Key val)+insert gs t = liftM fromIntegral+ . gsInsert gs (tableName t) (map fst3 $ tableColumns t)+ . toPersistValues+ where+ fst3 (x, _, _) = x++replace :: (Integral (Key v), ToPersistFields v, Monad m)+ => GenericSql m -> EntityDef -> Key v -> v -> m ()+replace gs t k val = do+ let sql = "UPDATE " ++ tableName t ++ " SET " +++ intercalate "," (map (go . fst3) $ tableColumns t) +++ " WHERE id=?"+ gsExecute gs sql $+ map toPersistValue (toPersistFields val)+ ++ [PersistInt64 (fromIntegral k)]+ where+ go = (++ "=?")+ fst3 (x, _, _) = x++get :: (Integral (Key v), FromPersistValues v, Monad m)+ => GenericSql m -> EntityDef -> Key v -> m (Maybe v)+get gs t k = do+ let sql = "SELECT * FROM " ++ tableName t ++ " WHERE id=?"+ gsWithStmt gs sql [PersistInt64 $ fromIntegral k] $ \pop -> do+ res <- pop+ case res of+ Nothing -> return Nothing+ Just (_:vals) ->+ case fromPersistValues vals of+ Left e -> error $ "get " ++ show k ++ ": " ++ e+ Right v -> return $ Just v+ Just [] -> error "Database.Persist.GenericSql: Empty list in get"++select :: ( FromPersistValues val, Num key+ , PersistField (Filter val), ToFieldName (Filter val)+ , ToFilter (Filter val), ToFieldName (Order val)+ , ToOrder (Order val), Monad m+ )+ => GenericSql m+ -> EntityDef+ -> [Filter val]+ -> [Order val]+ -> m [(key, val)]+select gs t filts ords = do+ let wher = if null filts+ then ""+ else " WHERE " +++ intercalate " AND " (map filterClause filts)+ ord = if null ords+ then ""+ else " ORDER BY " +++ intercalate "," (map orderClause ords)+ let sql = "SELECT * FROM " ++ tableName t ++ wher ++ ord+ gsWithStmt gs sql (map toPersistValue filts) $ flip go id+ where+ orderClause o = toFieldName' o ++ case toOrder o of+ Asc -> ""+ Desc -> " DESC"+ fromPersistValues' (PersistInt64 x:xs) = do+ case fromPersistValues xs of+ Left e -> Left e+ Right xs' -> Right (fromIntegral x, xs')+ fromPersistValues' _ = Left "error in fromPersistValues'"+ go pop front = do+ res <- pop+ case res of+ Nothing -> return $ front []+ Just vals -> do+ case fromPersistValues' vals of+ Left _ -> go pop front -- FIXME error?+ Right row -> go pop $ front . (:) row++filterClause :: (ToFilter f, ToFieldName f) => f -> String+filterClause f = if isNull f then nullClause else mainClause+ where+ mainClause = toFieldName' f ++ showSqlFilter (toFilter f) ++ "?"+ nullClause =+ case toFilter f of+ Eq -> '(' : mainClause ++ " OR " ++ toFieldName' f ++ " IS NULL)"+ Ne -> '(' : mainClause ++ " OR " ++ toFieldName' f ++ " IS NOT NULL)"+ _ -> mainClause+ showSqlFilter Eq = "="+ showSqlFilter Ne = "<>"+ showSqlFilter Gt = ">"+ showSqlFilter Lt = "<"+ showSqlFilter Ge = ">="+ showSqlFilter Le = "<="++delete :: (Integral (Key v), Monad m)+ => GenericSql m -> EntityDef -> Key v -> m ()+delete gs t k =+ gsExecute gs sql [PersistInt64 $ fromIntegral k]+ where+ sql = "DELETE FROM " ++ tableName t ++ " WHERE id=?"++deleteWhere :: (PersistField (Filter v), ToFilter (Filter v),+ ToFieldName (Filter v), Monad m)+ => GenericSql m -> EntityDef -> [Filter v] -> m ()+deleteWhere gs t filts = do+ let wher = if null filts+ then ""+ else " WHERE " +++ intercalate " AND " (map filterClause filts)+ sql = "DELETE FROM " ++ tableName t ++ wher+ gsExecute gs sql $ map toPersistValue filts++deleteBy :: (ToPersistFields (Unique v), ToFieldNames (Unique v), Monad m)+ => GenericSql m -> EntityDef -> Unique v -> m ()+deleteBy gs t uniq = do+ let sql = "DELETE FROM " ++ tableName t ++ " WHERE " +++ intercalate " AND " (map (++ "=?") $ toFieldNames' uniq)+ gsExecute gs sql $ map toPersistValue $ toPersistFields uniq++update :: ( Integral (Key v), PersistField (Update v), ToFieldName (Update v)+ , Monad m)+ => GenericSql m -> EntityDef -> Key v -> [Update v] -> m ()+update _ _ _ [] = return ()+update gs t k upds = do+ let sql = "UPDATE " ++ tableName t ++ " SET " +++ intercalate "," (map (++ "=?") $ map toFieldName' upds) +++ " WHERE id=?"+ gsExecute gs sql $+ map toPersistValue upds ++ [PersistInt64 $ fromIntegral k]++updateWhere :: (PersistField (Filter v), PersistField (Update v),+ ToFieldName (Update v), ToFilter (Filter v),+ ToFieldName (Filter v), Monad m)+ => GenericSql m+ -> EntityDef -> [Filter v] -> [Update v] -> m ()+updateWhere _ _ _ [] = return ()+updateWhere gs t filts upds = do+ let wher = if null filts+ then ""+ else " WHERE " +++ intercalate " AND " (map filterClause filts)+ let sql = "UPDATE " ++ tableName t ++ " SET " +++ intercalate "," (map (++ "=?") $ map toFieldName' upds) ++ wher+ let dat = map toPersistValue upds ++ map toPersistValue filts+ gsWithStmt gs sql dat $ const $ return ()++getBy :: (Num (Key v), FromPersistValues v, Monad m,+ ToPersistFields (Unique v), ToFieldNames (Unique v))+ => GenericSql m+ -> EntityDef -> Unique v -> m (Maybe (Key v, v))+getBy gs t uniq = do+ let sql = "SELECT * FROM " ++ tableName t ++ " WHERE " ++ sqlClause+ gsWithStmt gs sql (toPersistValues uniq) $ \pop -> do+ row <- pop+ case row of+ Nothing -> return Nothing+ Just (PersistInt64 k:vals) ->+ case fromPersistValues vals of+ Left _ -> return Nothing+ Right x -> return $ Just (fromIntegral k, x)+ Just _ -> error "Database.Persist.GenericSql: Bad list in getBy"+ where+ sqlClause = intercalate " AND " $ map (++ "=?") $ toFieldNames' uniq++tableName :: EntityDef -> String+tableName t = "tbl" ++ entityName t++toField :: String -> String+toField = (++) "fld"++tableColumns :: EntityDef -> [(String, String, [String])]+tableColumns = map (\(x, y, z) -> (toField x, y, z)) . entityColumns++tableUniques' :: EntityDef -> [(String, [String])]+tableUniques' = map (second $ map toField) . entityUniques++toFieldName' :: ToFieldName x => x -> String+toFieldName' = toField . toFieldName++toFieldNames' :: ToFieldNames x => x -> [String]+toFieldNames' = map toField . toFieldNames
+ Database/Persist/Helper.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExistentialQuantification #-}+-- | This module provides utilities for creating backends. Regular users do not+-- need to use this module.+module Database.Persist.Helper+ ( recName+ , upperFirst+ -- * High level design+ , EntityDef (..)+ , entityOrders+ , entityFilters+ , entityUpdates+ -- * TH datatype helpers+ , dataTypeDec+ , persistMonadTypeDec+ , keyTypeDec+ , filterTypeDec+ , updateTypeDec+ , orderTypeDec+ , uniqueTypeDec+ -- * TH typeclass helpers+ , mkToPersistFields+ , mkToFieldNames+ , mkToFieldName+ , mkPersistField+ , mkToFilter+ , mkToOrder+ , mkHalfDefined+ -- * Type classes+ , SomePersistField (..)+ , ToPersistFields (..)+ , FromPersistValues (..)+ , toPersistValues+ , ToFieldNames (..)+ , ToOrder (..)+ , PersistOrder (..)+ , ToFieldName (..)+ , PersistFilter (..)+ , ToFilter (..)+ , HalfDefined (..)+ -- * Utils+ , apE+ , addIsNullable+ ) where++import Database.Persist+import Language.Haskell.TH.Syntax+import Data.Char (toLower, toUpper)+import Data.Maybe (fromJust, mapMaybe)+import Web.Routes.Quasi (SinglePiece)++data EntityDef = EntityDef+ { entityName :: String+ , entityColumns :: [(String, String, [String])] -- ^ name, type, attribs+ , entityUniques :: [(String, [String])] -- ^ name, columns+ , entityDerives :: [String]+ }+ deriving Show++instance Lift EntityDef where+ lift (EntityDef a b c d) = do+ e <- [|EntityDef|]+ a' <- lift a+ b' <- lift b+ c' <- lift c+ d' <- lift d+ return $ e `AppE` a' `AppE` b' `AppE` c' `AppE` d'++recName :: String -> String -> String+recName dt f = lowerFirst dt ++ upperFirst f++lowerFirst :: String -> String+lowerFirst (x:xs) = toLower x : xs+lowerFirst [] = []++upperFirst :: String -> String+upperFirst (x:xs) = toUpper x : xs+upperFirst [] = []++dataTypeDec :: EntityDef -> Dec+dataTypeDec t =+ let name = mkName $ entityName t+ cols = map (mkCol $ entityName t) $ entityColumns t+ in DataD [] name [] [RecC name cols] $ map mkName $ entityDerives t+ where+ mkCol x (n, ty, as) =+ (mkName $ recName x n, NotStrict, pairToType (ty, "null" `elem` as))++persistMonadTypeDec :: Type -> EntityDef -> Dec+persistMonadTypeDec monad t =+ TySynInstD ''PersistMonad [ConT $ mkName $ entityName t] monad++keyTypeDec :: String -> String -> EntityDef -> Dec+keyTypeDec constr typ t =+ NewtypeInstD [] ''Key [ConT $ mkName $ entityName t]+ (NormalC (mkName constr) [(NotStrict, ConT $ mkName typ)])+ [''Show, ''Read, ''Num, ''Integral, ''Enum, ''Eq, ''Ord,+ ''Real, ''PersistField, ''SinglePiece]++filterTypeDec :: EntityDef -> Dec+filterTypeDec t =+ DataInstD [] ''Filter [ConT $ mkName $ entityName t]+ (map (mkFilter $ entityName t) filts)+ (if null filts then [] else [''Show, ''Read, ''Eq])+ where+ filts = entityFilters t++entityFilters :: EntityDef -> [(String, String, Bool, PersistFilter)]+entityFilters = mapMaybe go' . concatMap go . entityColumns+ where+ go (x, y, as) = map (\a -> (x, y, "null" `elem` as, a)) as+ go' (x, y, z, a) =+ case readMay a of+ Nothing -> Nothing+ Just a' -> Just (x, y, z, a')+ readMay s =+ case reads s of+ (x, _):_ -> Just x+ [] -> Nothing++mkFilter :: String -> (String, String, Bool, PersistFilter) -> Con+mkFilter x (s, ty, isNull', filt) =+ NormalC (mkName $ x ++ upperFirst s ++ show filt)+ [(NotStrict, pairToType (ty, isNull'))]++updateTypeDec :: EntityDef -> Dec+updateTypeDec t =+ DataInstD [] ''Update [ConT $ mkName $ entityName t]+ (map (mkUpdate $ entityName t) tu)+ (if null tu then [] else [''Show, ''Read, ''Eq])+ where+ tu = entityUpdates t++entityUpdates :: EntityDef -> [(String, String, Bool)]+entityUpdates = mapMaybe go . entityColumns+ where+ go (name, typ, attribs)+ | "update" `elem` attribs =+ Just (name, typ, "null" `elem` attribs)+ | otherwise = Nothing++mkUpdate :: String -> (String, String, Bool) -> Con+mkUpdate x (s, ty, isBool) =+ NormalC (mkName $ x ++ upperFirst s)+ [(NotStrict, pairToType (ty, isBool))]++orderTypeDec :: EntityDef -> Dec+orderTypeDec t =+ DataInstD [] ''Order [ConT $ mkName $ entityName t]+ (map (mkOrder $ entityName t) ords)+ (if null ords then [] else [''Show, ''Read, ''Eq])+ where+ ords = entityOrders t++entityOrders :: EntityDef -> [(String, String)]+entityOrders = concatMap go . entityColumns+ where+ go (x, _, ys) = mapMaybe (go' x) ys+ go' x "Asc" = Just (x, "Asc")+ go' x "Desc" = Just (x, "Desc")+ go' _ _ = Nothing++mkOrder :: String -> (String, String) -> Con+mkOrder x (s, ad) = NormalC (mkName $ x ++ upperFirst s ++ ad) []++uniqueTypeDec :: EntityDef -> Dec+uniqueTypeDec t =+ DataInstD [] ''Unique [ConT $ mkName $ entityName t]+ (map (mkUnique t) $ entityUniques t)+ (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq])++mkUnique :: EntityDef -> (String, [String]) -> Con+mkUnique t (constr, fields) =+ NormalC (mkName constr) types+ where+ types = map (go . fromJust . flip lookup3 (entityColumns t)) fields+ go (_, True) = error "Error: cannot have nullables in unique"+ go x = (NotStrict, pairToType x)+ lookup3 _ [] = Nothing+ lookup3 x ((x', y, z):rest)+ | x == x' = Just (y, "null" `elem` z)+ | otherwise = lookup3 x rest++pairToType :: (String, Bool) -> Type+pairToType (s, False) = ConT $ mkName s+pairToType (s, True) = ConT (mkName "Maybe") `AppT` ConT (mkName s)++data SomePersistField = forall a. PersistField a => SomePersistField a+instance PersistField SomePersistField where+ toPersistValue (SomePersistField a) = toPersistValue a+ fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String)+ sqlType (SomePersistField a) = sqlType a++class ToPersistFields a where+ toPersistFields :: a -> [SomePersistField]++degen :: [Clause] -> [Clause]+degen [] =+ let err = VarE (mkName "error") `AppE` LitE (StringL+ "Degenerate case, should never happen")+ in [Clause [WildP] (NormalB err) []]+degen x = x++mkToPersistFields :: Type+ -> [(String, Int)]+ -> Q Dec+mkToPersistFields typ pairs = do+ clauses <- mapM go pairs+ return $ InstanceD [] (ConT ''ToPersistFields `AppT` typ)+ [FunD (mkName "toPersistFields") $ degen clauses]+ where+ go (constr, fields) = do+ xs <- sequence $ replicate fields $ newName "x"+ let pat = ConP (mkName constr) $ map VarP xs+ sp <- [|SomePersistField|]+ let bod = ListE $ map (AppE sp . VarE) xs+ return $ Clause [pat] (NormalB bod) []++class FromPersistValues a where+ fromPersistValues :: [PersistValue] -> Either String a++toPersistValues :: ToPersistFields a => a -> [PersistValue]+toPersistValues = map toPersistValue . toPersistFields++class ToFieldNames a where+ toFieldNames :: a -> [String]++mkToFieldNames :: Type -> [(String, [String])] -> Dec+mkToFieldNames typ pairs =+ InstanceD [] (ConT ''ToFieldNames `AppT` typ)+ [FunD (mkName "toFieldNames") $ degen $ map go pairs]+ where+ go (constr, names) =+ Clause [RecP (mkName constr) []]+ (NormalB $ ListE $ map (LitE . StringL) names)+ []++class ToFieldName a where+ toFieldName :: a -> String++mkToFieldName :: Type -> [(String, String)] -> Dec+mkToFieldName typ pairs =+ InstanceD [] (ConT ''ToFieldName `AppT` typ)+ [FunD (mkName "toFieldName") $ degen $ map go pairs]+ where+ go (constr, name) =+ Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) []++data PersistOrder = Asc | Desc+class ToOrder a where+ toOrder :: a -> PersistOrder++mkToOrder :: Type -> [(String, String)] -> Dec+mkToOrder typ pairs =+ InstanceD [] (ConT ''ToOrder `AppT` typ)+ [FunD (mkName "toOrder") $ degen $ map go pairs]+ where+ go (constr, val) =+ Clause [RecP (mkName constr) []] (NormalB $ ConE $ mkName val) []++data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le+ deriving (Read, Show)+class ToFilter a where+ toFilter :: a -> PersistFilter+ isNull :: a -> Bool++mkToFilter :: Type -> [(String, PersistFilter, Bool)] -> Dec+mkToFilter typ pairs =+ InstanceD [] (ConT ''ToFilter `AppT` typ)+ [ FunD (mkName "toFilter") $ degen $ map go pairs+ , FunD (mkName "isNull") $ degen $ concatMap go' pairs+ ]+ where+ go (constr, pf, _) =+ Clause [RecP (mkName constr) []] (NormalB $ ConE $ mkName $ show pf) []+ go' (constr, _, False) =+ [Clause [RecP (mkName constr) []]+ (NormalB $ ConE $ mkName "False") []]+ go' (constr, _, True) =+ [ Clause [ConP (mkName constr) [ConP (mkName "Nothing") []]]+ (NormalB $ ConE $ mkName "True") []+ , Clause [ConP (mkName constr) [WildP]]+ (NormalB $ ConE $ mkName "False") []+ ]++mkPersistField :: Type -> [String] -> Dec+mkPersistField typ constrs =+ InstanceD [] (ConT ''PersistField `AppT` typ)+ $ fpv : map go+ [ "toPersistValue"+ , "sqlType"+ , "isNullable"+ ]+ where+ go func = FunD (mkName func) $ degen $ map (go' func) constrs+ go' func constr =+ let x = mkName "x"+ in Clause [ConP (mkName constr) [VarP x]]+ (NormalB $ VarE (mkName func) `AppE` VarE x)+ []+ fpv = FunD (mkName "fromPersistValue")+ [Clause [WildP] (NormalB $ VarE (mkName "error")+ `AppE` LitE (StringL "fromPersistValue")) []]++class HalfDefined a where+ halfDefined :: a++mkHalfDefined :: Type -> String -> Int -> Dec+mkHalfDefined typ constr count =+ InstanceD [] (ConT ''HalfDefined `AppT` typ)+ [FunD (mkName "halfDefined")+ [Clause [] (NormalB+ $ foldl AppE (ConE $ mkName constr)+ (replicate count $ VarE $ mkName "undefined")) []]]++apE :: Either x (y -> z) -> Either x y -> Either x z+apE (Left x) _ = Left x+apE _ (Left x) = Left x+apE (Right f) (Right y) = Right $ f y++addIsNullable :: EntityDef -> (String, (String, String))+ -> (String, (String, Bool))+addIsNullable ed (col, (name, typ)) =+ case filter (\(x, _, _) -> x == col) $ entityColumns ed of+ [] -> error $ "Missing columns: " ++ col ++ ", " ++ show ed+ (_, _, attribs):_ -> (name, (typ, "null" `elem` attribs))
+ Database/Persist/Quasi.hs view
@@ -0,0 +1,56 @@+module Database.Persist.Quasi+ ( persist+ ) where++import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Database.Persist.Helper+import Data.Char+import Data.Maybe (mapMaybe)++-- | Converts a quasi-quoted syntax into a list of entity definitions, to be+-- used as input to the backend-specific template haskell generation code.+persist :: QuasiQuoter+persist = QuasiQuoter+ { quoteExp = lift . parse+ , quotePat = error "Cannot quasi-quote a Persist pattern."+ }++parse :: String -> [EntityDef]+parse = map parse' . nest . map words' . filter (not . null) . lines++words' :: String -> (Bool, [String])+words' (' ':x) = (True, words x)+words' x = (False, words x)++nest :: [(Bool, [String])] -> [(String, [[String]])]+nest ((False, [name]):rest) =+ let (x, y) = break (not . fst) rest+ in (name, map snd x) : nest y+nest ((False, _):_) = error "First line in block must have exactly one word"+nest ((True, _):_) = error "Blocks must begin with non-indented lines"+nest [] = []++parse' :: (String, [[String]]) -> EntityDef+parse' (name, attribs) = EntityDef name cols uniqs derives+ where+ cols = concatMap takeCols attribs+ uniqs = concatMap takeUniqs attribs+ derives = case mapMaybe takeDerives attribs of+ [] -> ["Show", "Read", "Eq"]+ x -> concat x++takeCols :: [String] -> [(String, String, [String])]+takeCols ("deriving":_) = []+takeCols (n@(f:_):ty:rest)+ | isLower f = [(n, ty, rest)]+takeCols _ = []++takeUniqs :: [String] -> [(String, [String])]+takeUniqs (n@(f:_):rest)+ | isUpper f = [(n, rest)]+takeUniqs _ = []++takeDerives :: [String] -> Maybe [String]+takeDerives ("deriving":rest) = Just rest+takeDerives _ = Nothing
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Michael Snoyman. 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ persistent.cabal view
@@ -0,0 +1,33 @@+name: persistent+version: 0.0.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: Type-safe, non-relational, multi-backend persistence.+description: This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful.+category: Database+stability: Stable+cabal-version: >= 1.6+build-type: Simple+homepage: http://docs.yesodweb.com/persistent/++library+ build-depends: base >= 4 && < 5,+ template-haskell >= 2.4 && < 2.5,+ bytestring >= 0.9.1 && < 0.10,+ MonadCatchIO-transformers >= 0.2.2 && < 0.3,+ time >= 1.1.4 && < 1.2,+ utf8-string >= 0.3.4 && < 0.4,+ text >= 0.7.1 && < 0.8,+ hamlet >= 0.3.1 && < 0.4,+ web-routes-quasi >= 0.4.0 && < 0.5+ exposed-modules: Database.Persist+ Database.Persist.Helper+ Database.Persist.Quasi+ Database.Persist.GenericSql+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/snoyberg/persistent.git