persistent 0.3.0.1 → 0.3.1
raw patch · 4 files changed
+93/−29 lines, 4 filesdep ~stm
Dependency ranges changed: stm
Files
- Database/Persist/Base.hs +12/−0
- Database/Persist/GenericSql.hs +18/−4
- Database/Persist/TH.hs +61/−23
- persistent.cabal +2/−2
Database/Persist/Base.hs view
@@ -20,6 +20,7 @@ , EntityDef (..) , PersistBackend (..) , PersistFilter (..)+ , PersistUpdate (..) , PersistOrder (..) , SomePersistField (..) , selectList@@ -269,6 +270,7 @@ persistOrderToOrder :: Order val -> PersistOrder persistUpdateToFieldName :: Update val -> String+ persistUpdateToUpdate :: Update val -> PersistUpdate persistUpdateToValue :: Update val -> PersistValue persistUniqueToFieldNames :: Unique val -> [String]@@ -432,3 +434,13 @@ data PersistException = PersistMarshalException String deriving (Show, Typeable) instance E.Exception PersistException++data PersistUpdate = Update | Add | Subtract | Multiply | Divide+ deriving (Read, Show)++instance Lift PersistUpdate where+ lift Update = [|Update|]+ lift Add = [|Add|]+ lift Subtract = [|Subtract|]+ lift Multiply = [|Multiply|]+ lift Divide = [|Divide|]
Database/Persist/GenericSql.hs view
@@ -262,7 +262,12 @@ update _ [] = return () update k upds = do conn <- SqlPersist ask- let go' x = escapeName conn x ++ "=?"+ let go'' n Update = n ++ "=?"+ go'' n Add = n ++ '=' : n ++ "+?"+ go'' n Subtract = n ++ '=' : n ++ "-?"+ go'' n Multiply = n ++ '=' : n ++ "*?"+ go'' n Divide = n ++ '=' : n ++ "/?"+ let go' (x, pu) = go'' (escapeName conn x) pu let sql = concat [ "UPDATE " , escapeName conn $ rawTableName t@@ -274,7 +279,9 @@ map persistUpdateToValue upds ++ [PersistInt64 $ fromPersistKey k] where t = entityDef $ dummyFromKey k- go = getFieldName t . persistUpdateToFieldName+ go x = ( getFieldName t $ persistUpdateToFieldName x+ , persistUpdateToUpdate x+ ) updateWhere _ [] = return () updateWhere filts upds = do@@ -294,8 +301,15 @@ execute' sql dat where t = entityDef $ dummyFromFilts filts- go = getFieldName t . persistUpdateToFieldName- go' conn x = escapeName conn x ++ "=?"+ go'' n Update = n ++ "=?"+ go'' n Add = n ++ '=' : n ++ "+?"+ go'' n Subtract = n ++ '=' : n ++ "-?"+ go'' n Multiply = n ++ '=' : n ++ "*?"+ go'' n Divide = n ++ '=' : n ++ "/?"+ go' conn (x, pu) = go'' (escapeName conn x) pu+ go x = ( getFieldName t $ persistUpdateToFieldName x+ , persistUpdateToUpdate x+ ) getBy uniq = do conn <- SqlPersist ask
Database/Persist/TH.hs view
@@ -17,6 +17,7 @@ import Web.Routes.Quasi (SinglePiece) import Data.Int (Int64) import Control.Monad (forM)+import System.IO.Unsafe (unsafePerformIO) -- | Create data types and appropriate 'PersistEntity' instances for the given -- 'EntityDef's. Works well with the persist quasi-quoter.@@ -41,7 +42,7 @@ 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))+ (mkName $ recName x n, NotStrict, pairToType (ty, nullable as)) keyTypeDec :: String -> Name -> EntityDef -> Dec keyTypeDec constr typ t =@@ -61,16 +62,18 @@ 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, as) = map (\a -> (x, y, nullable 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 +readMay :: Read a => String -> Maybe a+readMay s =+ case reads s of+ (x, _):_ -> Just x+ [] -> Nothing+ isFilterList :: PersistFilter -> Bool isFilterList In = True isFilterList NotIn = True@@ -99,18 +102,21 @@ where tu = entityUpdates t -entityUpdates :: EntityDef -> [(String, String, Bool)]-entityUpdates = mapMaybe go . entityColumns+entityUpdates :: EntityDef -> [(String, String, Bool, PersistUpdate)]+entityUpdates = mapMaybe go' . concatMap go . entityColumns where- go (name, typ, attribs)- | "update" `elem` attribs =- Just (name, typ, "null" `elem` attribs)- | otherwise = Nothing+ go (x, y, as) = map (\a -> (x, y, nullable as, a)) as+ go' (x, y, z, "update") =+ deprecate "'update' is deprecated; please use 'Update'"+ $ Just (x, y, z, Update)+ go' (x, y, z, a) =+ case readMay a of+ Nothing -> Nothing+ Just a' -> Just (x, y, z, a') -mkUpdate :: String -> (String, String, Bool) -> Con-mkUpdate x (s, ty, isBool) =- NormalC (mkName $ x ++ upperFirst s)- [(NotStrict, pairToType (ty, isBool))]+mkUpdate :: String -> (String, String, Bool, PersistUpdate) -> Con+mkUpdate x (s, ty, isBool, pu) =+ NormalC (mkName $ updateConName x s pu) [(NotStrict, pairToType (ty, isBool))] orderTypeDec :: EntityDef -> Q Dec orderTypeDec t = do@@ -149,7 +155,7 @@ lookup3 s [] = error $ "Column not found: " ++ s ++ " in unique " ++ constr lookup3 x ((x', y, z):rest)- | x == x' = (y, "null" `elem` z)+ | x == x' = (y, nullable z) | otherwise = lookup3 x rest pairToType :: (String, Bool) -> Type@@ -184,6 +190,15 @@ (NormalB $ ListE $ map (LitE . StringL) names) [] +mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec+mkToUpdate name pairs = do+ pairs' <- mapM go pairs+ return $ FunD (mkName name) $ degen pairs'+ where+ go (constr, pu) = do+ pu' <- lift pu+ return $ Clause [RecP (mkName constr) []] (NormalB pu') []+ mkUniqueToValues :: [(String, [String])] -> Q Dec mkUniqueToValues pairs = do pairs' <- mapM go pairs@@ -305,6 +320,9 @@ $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, isFilterList y)) $ entityFilters t+ putu <- mkToUpdate "persistUpdateToUpdate"+ $ map (\(s, _, _, pu) -> (updateConName name s pu, pu))+ $ entityUpdates t return [ dataTypeDec t , TySynD (mkName $ entityName t ++ "Id") [] $@@ -329,11 +347,12 @@ $ map (\(x, y, z) -> (name ++ upperFirst x ++ y, z)) entityOrders' , mkToFieldName "persistUpdateToFieldName"- $ map (\(s, _, _) -> (name ++ upperFirst s, s))+ $ map (\(s, _, _, pu) -> (updateConName name s pu, s)) $ entityUpdates t , mkToValue "persistUpdateToValue"- $ map (\(s, _, _) -> name ++ upperFirst s)+ $ map (\(s, _, _, pu) -> updateConName name s pu) $ entityUpdates t+ , putu , mkToFieldName "persistFilterToFieldName" $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x)) $ entityFilters t@@ -344,6 +363,15 @@ ] ++ tf ] +updateConName :: String -> String -> PersistUpdate -> String+updateConName name s pu = concat+ [ name+ , upperFirst s+ , case pu of+ Update -> ""+ _ -> show pu+ ]+ share2 :: ([EntityDef] -> Q [Dec]) -> ([EntityDef] -> Q [Dec]) -> [EntityDef]@@ -378,7 +406,7 @@ concatMap getDeps' $ entityColumns def where getDeps' (name, typ, attribs) =- let isNull = "null" `elem` attribs+ let isNull = nullable attribs l = length typ (f, b) = splitAt (l - 2) typ in if b == "Id"@@ -447,10 +475,10 @@ fpv <- [|\dt v -> case fromPersistValue v of Left e -> Left e- Right s ->- case reads s of+ Right s' ->+ case reads s' of (x, _):_ -> Right x- [] -> Left $ "Invalid " ++ dt ++ ": " ++ s|]+ [] -> Left $ "Invalid " ++ dt ++ ": " ++ s'|] return [ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName s)) [ FunD (mkName "sqlType")@@ -464,3 +492,13 @@ ] ] ]++nullable :: [String] -> Bool+nullable s+ | "null" `elem` s = deprecate "Please replace null with Maybe" True+ | otherwise = "Maybe" `elem` s++deprecate :: String -> a -> a+deprecate s x = unsafePerformIO $ do+ putStrLn $ "DEPRECATED: " ++ s+ return x
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.3.0.1+version: 0.3.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -24,7 +24,7 @@ containers >= 0.2 && < 0.5, parsec >= 2.1 && < 4, enumerator >= 0.4 && < 0.5,- stm >= 2.1 && < 2.2,+ stm >= 2.1 && < 2.3, neither >= 0.1 && < 0.2 exposed-modules: Database.Persist Database.Persist.Base