persistent-template 1.1.1 → 1.1.2
raw patch · 2 files changed
+43/−31 lines, 2 filesdep ~persistentPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: persistent
API changes (from Hackage documentation)
Files
- Database/Persist/TH.hs +41/−29
- persistent-template.cabal +2/−2
Database/Persist/TH.hs view
@@ -39,7 +39,7 @@ import Database.Persist.Query.Internal import Database.Persist.GenericSql (Migration, SqlPersist, migrate) import Database.Persist.GenericSql.Raw (SqlBackend)-import Database.Persist.Util (nullable)+import Database.Persist.Util (nullable, IsNullable(..), WhyNullable(..)) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Data.Char (toLower, toUpper)@@ -174,7 +174,7 @@ sumCon fd@(FieldDef _ _ ty _) = NormalC (sumConstrName t fd)- [(NotStrict, pairToType mps backend (ty, False))]+ [(NotStrict, pairToType mps backend (ty, NotNullable))] sumConstrName :: EntityDef -> FieldDef -> Name sumConstrName t (FieldDef n _ _ _) = mkName $ unpack $ concat@@ -189,7 +189,7 @@ (x, _):_ -> Just x [] -> Nothing -entityUpdates :: EntityDef -> [(HaskellName, FieldType, Bool, PersistUpdate)]+entityUpdates :: EntityDef -> [(HaskellName, FieldType, IsNullable, PersistUpdate)] entityUpdates = concatMap go . entityFields where@@ -205,29 +205,42 @@ 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 - go :: (FieldType, Bool) -> (Strict, Type)- go (_, True) = error "Error: cannot have nullables in unique"+ force = "!force" `elem` attrs++ go :: (FieldType, IsNullable) -> (Strict, Type)+ go (ft, Nullable _) | not force = error nullErrMsg go (ft, y) = (NotStrict, pairToType mps backend (ft, y)) - lookup3 :: Text -> [FieldDef] -> (FieldType, Bool)+ lookup3 :: Text -> [FieldDef] -> (FieldType, IsNullable) lookup3 s [] = error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr lookup3 x ((FieldDef (HaskellName x') _ y z):rest) | 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+ -> (FieldType, IsNullable) -> Type-pairToType mps backend (s, False) = idType mps backend s-pairToType mps backend (s, True) = ConT (mkName "Maybe") `AppT` idType mps backend s+pairToType mps backend (s, Nullable ByMaybeAttr) =+ ConT (mkName "Maybe") `AppT` idType mps backend s+pairToType mps backend (s, _) = idType mps backend s backendDataType :: MkPersistSettings -> Type backendDataType mps@@ -303,7 +316,7 @@ 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@@ -326,7 +339,7 @@ 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|]@@ -535,7 +548,7 @@ { depTarget :: Text , depSourceTable :: HaskellName , depSourceField :: HaskellName- , depSourceNull :: Bool+ , depSourceNull :: IsNullable } -- | Generate a 'DeleteCascade' instance for the given @EntityDef@s.@@ -550,16 +563,15 @@ where getDeps' :: FieldDef -> [Dep] getDeps' (FieldDef name _ ftyp attribs) =- let isNull = nullable attribs- in case stripId ftyp of- Just f ->- return Dep- { depTarget = f- , depSourceTable = entityHaskell def- , depSourceField = name- , depSourceNull = isNull- }- Nothing -> []+ case stripId ftyp of+ Just f ->+ return Dep+ { depTarget = f+ , depSourceTable = entityHaskell def+ , depSourceField = name+ , depSourceNull = nullable attribs+ }+ Nothing -> [] go :: [Dep] -> EntityDef -> Q Dec go allDeps EntityDef{entityHaskell = name} = do let deps = filter (\x -> depTarget x == unHaskellName name) allDeps@@ -581,8 +593,8 @@ where filtName = unHaskellName (depSourceTable dep) ++ upperFirst (unHaskellName $ depSourceField dep)- val False = VarE key- val True = just `AppE` VarE key+ val (Nullable ByMaybeAttr) = just `AppE` VarE key+ val _ = VarE key @@ -620,7 +632,7 @@ 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@@ -718,7 +730,7 @@ 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@@ -793,7 +805,7 @@ , upperFirst $ unHaskellName $ fieldHaskell cd ] maybeTyp =- if nullable $ fieldAttrs cd+ if nullable (fieldAttrs cd) == Nullable ByMaybeAttr then ConT ''Maybe `AppT` typ else typ typ =@@ -864,6 +876,6 @@ pulls = map toPull $ entityFields def toPull f = InfixE (Just $ VarE obj)- (if nullable (fieldAttrs f) then dotColonQE else dotColonE)+ (if nullable (fieldAttrs f) == Nullable ByMaybeAttr then dotColonQE else dotColonE) (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f) return [toJSONI, fromJSONI]
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 1.1.1+version: 1.1.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -16,7 +16,7 @@ library build-depends: base >= 4 && < 5 , template-haskell- , persistent >= 1.1 && < 1.2+ , persistent >= 1.1.2 && < 1.2 , monad-control >= 0.2 && < 0.4 , text >= 0.5 && < 1.0 , transformers >= 0.2 && < 0.4