diff --git a/Database/Persist/Base.hs b/Database/Persist/Base.hs --- a/Database/Persist/Base.hs +++ b/Database/Persist/Base.hs @@ -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|] diff --git a/Database/Persist/GenericSql.hs b/Database/Persist/GenericSql.hs --- a/Database/Persist/GenericSql.hs +++ b/Database/Persist/GenericSql.hs @@ -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 diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -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 diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 0.3.0.1 +version: 0.3.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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