Skip to content
Browse files

Force the use of a "!force" attribute for NULLables on uniques.

  • Loading branch information...
1 parent 012aa5d commit 75196e250c98edb174a917c5415af9b7707334ae @meteficha committed Dec 14, 2012
View
2 persistent-sqlite/Database/Persist/Sqlite.hs
@@ -250,7 +250,7 @@ sqlColumn (Column name isNull typ def _maxLen ref) = concat
]
sqlUnique :: UniqueDef -> String
-sqlUnique (UniqueDef _ cname cols) = concat
+sqlUnique (UniqueDef _ cname cols _) = concat
[ ",CONSTRAINT "
, T.unpack $ escape cname
, " UNIQUE ("
View
23 persistent-template/Database/Persist/TH.hs
@@ -205,13 +205,16 @@ uniqueTypeDec mps t =
backend = mkName "backend"
mkUnique :: MkPersistSettings -> Name -> EntityDef -> UniqueDef -> Con
-mkUnique mps backend t (UniqueDef (HaskellName constr) _ fields) =
+mkUnique mps backend t (UniqueDef (HaskellName constr) _ fields attrs) =
NormalC (mkName $ unpack constr) types
where
types = map (go . flip lookup3 (entityFields t))
$ map (unHaskellName . fst) fields
+ force = "!force" `elem` attrs
+
go :: (FieldType, Bool) -> (Strict, Type)
+ go (ft, True) | not force = error nullErrMsg
go (ft, y) = (NotStrict, pairToType mps backend (ft, y))
lookup3 :: Text -> [FieldDef] -> (FieldType, Bool)
@@ -221,6 +224,16 @@ mkUnique mps backend t (UniqueDef (HaskellName constr) _ fields) =
| x == x' = (y, nullable z)
| otherwise = lookup3 x rest
+ nullErrMsg =
+ mconcat [ "Error: By default we disallow NULLables in an uniqueness "
+ , "constraint. The semantics of how NULL interacts with those "
+ , "constraints is non-trivial: two NULL values are not "
+ , "considered equal for the purposes of an uniqueness "
+ , "constraint. If you understand this feature, it is possible "
+ , "to use it your advantage. *** Use a \"!force\" attribute "
+ , "on the end of the line that defines your uniqueness "
+ , "constraint in order to disable this check. ***" ]
+
pairToType :: MkPersistSettings
-> Name -- ^ backend
-> (FieldType, Bool) -- ^ True == has Maybe attr
@@ -302,7 +315,7 @@ mkToFieldNames pairs = do
pairs' <- mapM go pairs
return $ FunD (mkName "persistUniqueToFieldNames") $ degen pairs'
where
- go (UniqueDef constr _ names) = do
+ go (UniqueDef constr _ names _) = do
names' <- lift names
return $
Clause
@@ -325,7 +338,7 @@ mkUniqueToValues pairs = do
return $ FunD (mkName "persistUniqueToValues") $ degen pairs'
where
go :: UniqueDef -> Q Clause
- go (UniqueDef constr _ names) = do
+ go (UniqueDef constr _ names _) = do
xs <- mapM (const $ newName "x") names
let pat = ConP (mkName $ unpack $ unHaskellName constr) $ map VarP xs
tpv <- [|toPersistValue|]
@@ -619,7 +632,7 @@ mkUniqueKeys def = do
return $ Clause [pat] (NormalB $ ListE pcs) []
go :: [(HaskellName, Name)] -> UniqueDef -> Exp
- go xs (UniqueDef name _ cols) =
+ go xs (UniqueDef name _ cols _) =
foldl' (go' xs) (ConE (mkName $ unpack $ unHaskellName name)) (map fst cols)
go' :: [(HaskellName, Name)] -> Exp -> HaskellName -> Exp
@@ -717,7 +730,7 @@ instance Lift EntityDef where
instance Lift FieldDef where
lift (FieldDef a b c d) = [|FieldDef $(lift a) $(lift b) $(lift c) $(liftTs d)|]
instance Lift UniqueDef where
- lift (UniqueDef a b c) = [|UniqueDef $(lift a) $(lift b) $(lift c)|]
+ lift (UniqueDef a b c d) = [|UniqueDef $(lift a) $(lift b) $(lift c) $(liftTs d)|]
pack' :: String -> Text
pack' = pack
View
2 persistent-test/UniqueTest.hs
@@ -28,7 +28,7 @@ share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persist|
TestNull
fieldA Int
fieldB Int Maybe
- UniqueTestNull fieldA fieldB
+ UniqueTestNull fieldA fieldB !force
deriving Eq Show
|]
#ifdef WITH_MONGODB
View
1 persistent/Database/Persist/EntityDef.hs
@@ -56,6 +56,7 @@ data UniqueDef = UniqueDef
{ uniqueHaskell :: HaskellName
, uniqueDBName :: DBName
, uniqueFields :: [(HaskellName, DBName)]
+ , uniqueAttrs :: [Attr]
}
deriving (Show, Eq, Read, Ord)
View
4 persistent/Database/Persist/Quasi.hs
@@ -248,8 +248,10 @@ takeUniqs ps defs (n:rest)
= Just $ UniqueDef
(HaskellName n)
(DBName $ psToDBName ps n)
- (map (HaskellName &&& getDBName defs) rest)
+ (map (HaskellName &&& getDBName defs) fields)
+ attrs
where
+ (fields,attrs) = break ("!" `T.isPrefixOf`) rest
getDBName [] t = error $ "Unknown column in unique constraint: " ++ show t
getDBName (d:ds) t
| fieldHaskell d == HaskellName t = fieldDB d

0 comments on commit 75196e2

Please sign in to comment.
Something went wrong with that request. Please try again.