diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -53,7 +53,7 @@ import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.IO as TIO import Data.List (foldl') -import Data.Maybe (isJust, listToMaybe, mapMaybe) +import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe) import Data.Monoid (mappend, mconcat) import Text.Read (readPrec, lexP, step, prec, parens, Lexeme(Ident)) import qualified Data.Map as M @@ -151,7 +151,7 @@ data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp instance Lift FieldSqlTypeExp where lift (FieldSqlTypeExp (FieldDef{..}) sqlTypeExp) = - [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) $(liftTs fieldAttrs) fieldStrict fieldReference|] + [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) $(lift' fieldAttrs) fieldStrict fieldReference|] instance Lift EntityDefSqlTypeExp where lift (EntityDefSqlTypeExp (EntityDef{..}) sqlTypeExps) = @@ -159,13 +159,13 @@ $(lift entityHaskell) $(lift entityDB) $(lift entityID) - $(liftTs entityAttrs) + $(lift' entityAttrs) $(lift (FieldsSqlTypeExp entityFields sqlTypeExps)) $(lift entityPrimary) $(lift entityUniques) $(lift entityForeigns) - $(liftTs entityDerives) - $(liftMap entityExtra) + $(lift' entityDerives) + $(lift' entityExtra) $(lift entitySum) |] @@ -350,7 +350,7 @@ mkCol x fd@FieldDef {..} = (mkName $ unpack $ recName mps x fieldHaskell, if fieldStrict then IsStrict else NotStrict, - pairToType mps backend (fd, nullable fieldAttrs) + maybeIdType mps fd Nothing Nothing ) (nameFinal, paramsFinal) | mpsGeneric mps = (nameG, [PlainTV backend]) @@ -358,7 +358,7 @@ nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Generic" name = mkName $ unpack $ unHaskellName $ entityHaskell t cols = map (mkCol $ entityHaskell t) $ entityFields t - backend = mkName "backend" + backend = backendName constrs | entitySum t = map sumCon $ entityFields t @@ -366,7 +366,7 @@ sumCon fd = NormalC (sumConstrName mps t fd) - [(NotStrict, pairToType mps backend (fd, NotNullable))] + [(NotStrict, maybeIdType mps fd Nothing Nothing)] sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat @@ -381,13 +381,11 @@ uniqueTypeDec mps t = DataInstD [] ''Unique [genericDataType mps (entityHaskell t) backendT] - (map (mkUnique mps backend t) $ entityUniques t) + (map (mkUnique mps t) $ entityUniques t) [] - where - backend = mkName "backend" -mkUnique :: MkPersistSettings -> Name -> EntityDef -> UniqueDef -> Con -mkUnique mps backend t (UniqueDef (HaskellName constr) _ fields attrs) = +mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con +mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) = NormalC (mkName $ unpack constr) types where types = map (go . flip lookup3 (entityFields t)) @@ -397,7 +395,7 @@ go :: (FieldDef, IsNullable) -> (Strict, Type) go (_, Nullable _) | not force = error nullErrMsg - go (fd, y) = (NotStrict, pairToType mps backend (fd, y)) + go (fd, y) = (NotStrict, maybeIdType mps fd Nothing (Just y)) lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable) lookup3 s [] = @@ -416,13 +414,17 @@ , "on the end of the line that defines your uniqueness " , "constraint in order to disable this check. ***" ] -pairToType :: MkPersistSettings - -> Name -- ^ backend - -> (FieldDef, IsNullable) +maybeIdType :: MkPersistSettings + -> FieldDef + -> Maybe Name -- ^ backend + -> Maybe IsNullable -> Type -pairToType mps backend (fd, Nullable ByMaybeAttr) = - ConT ''Maybe `AppT` idType mps backend fd -pairToType mps backend (fd, _) = idType mps backend fd +maybeIdType mps fd mbackend mnull = maybeTyp mayNullable idtyp + where + mayNullable = case mnull of + (Just (Nullable ByMaybeAttr)) -> True + _ -> maybeNullable fd + idtyp = idType mps fd mbackend backendDataType :: MkPersistSettings -> Type backendDataType mps @@ -437,12 +439,12 @@ | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend | otherwise = ConT $ mkName $ unpack typ' -idType :: MkPersistSettings -> Name -> FieldDef -> Type -idType mps backend fd = +idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type +idType mps fd mbackend = case foreignReference fd of Just typ' -> ConT ''Key - `AppT` genericDataType mps typ' (VarT backend) + `AppT` genericDataType mps typ' (VarT $ fromMaybe backendName mbackend) Nothing -> ftToType typ where typ = fieldType fd @@ -549,10 +551,9 @@ , map (const null') after ] constr = ConE $ sumConstrName mps t field - fmap' <- [|fmap|] fs <- [|fromPersistValue $(return $ VarE x)|] let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x - let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmap' (Just fs))]) [] + let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) [] clauses <- mkClauses (field : before) after return $ clause : clauses @@ -561,6 +562,9 @@ lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) +fmapE :: Exp +fmapE = VarE 'fmap + mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause] mkLensClauses mps t = do lens' <- [|lensPTH|] @@ -710,8 +714,11 @@ unKeyName t = mkName $ "un" `mappend` keyString t backendT :: Type -backendT = VarT $ mkName "backend" +backendT = VarT backendName +backendName :: Name +backendName = mkName "backend" + keyConName :: EntityDef -> Name keyConName = mkName . keyString @@ -728,15 +735,16 @@ mkKeyToValues _mps t = do (p, e) <- case entityPrimary t of Nothing -> - ([],) <$> [|backendKeyToValues . $(return $ VarE $ unKeyName t)|] + ([],) <$> [|(:[]) . toPersistValue . $(return $ VarE $ unKeyName t)|] Just pdef -> - newName "record" >>= return . toValuesPrimary pdef + return $ toValuesPrimary pdef return $ FunD 'keyToValues $ return $ normalClause p e where - toValuesPrimary pdef recordName = + toValuesPrimary pdef = ( [VarP recordName] , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName t fd) `AppE` VarE recordName)) $ primaryFields pdef ) + recordName = mkName "record" normalClause :: [Pat] -> Exp -> Clause normalClause p e = Clause p (NormalB e) [] @@ -745,7 +753,7 @@ mkKeyFromValues _mps t = do clauses <- case entityPrimary t of Nothing -> do - e <- [|fmap $(return keyConE) . backendKeyFromValues|] + e <- [|fmap $(return keyConE) . fromPersistValue . headNote|] return $ [normalClause [] e] Just pdef -> fromValues t "keyFromValues" keyConE (primaryFields pdef) @@ -753,6 +761,12 @@ where keyConE = ConE (keyConName t) +headNote :: [PersistValue] -> PersistValue +headNote (x:[]) = x +headNote xs = error $ "mkKeyFromValues: expected a list of one element, got: " + `mappend` show xs + + fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause] fromValues t funName conE fields = do x <- newName "x" @@ -769,8 +783,8 @@ x1 <- newName "x1" restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fieldsNE] (fpv1:mkPersistValues) <- mapM mkPvFromFd fieldsNE - fmapE <- [|(<$>)|] - let conApp = infixFromPersistValue fmapE fpv1 conE x1 + app1E <- [|(<$>)|] + let conApp = infixFromPersistValue app1E fpv1 conE x1 applyE <- [|(<*>)|] let applyFromPersistValue = infixFromPersistValue applyE @@ -890,10 +904,10 @@ -- FIXME if we want to get really fancy, then: if this field is the -- *only* Id field present, then set backend1 and backend2 to different -- values - backend1 = mkName "backend" - backend2 = mkName "backend" - aT = pairToType mps backend1 (field, nullable $ fieldAttrs field) - bT = pairToType mps backend2 (field, nullable $ fieldAttrs field) + backend1 = backendName + backend2 = backendName + aT = maybeIdType mps field (Just backend1) Nothing + bT = maybeIdType mps field (Just backend2) Nothing mkST backend = genericDataType mps (entityHaskell ent) (VarT backend) sT = mkST backend1 tT = mkST backend2 @@ -906,7 +920,7 @@ (sT `arrow` (VarT fT `AppT` tT)) , FunD lensName $ return $ Clause [VarP fN, VarP aN] - (NormalB $ VarE 'fmap + (NormalB $ fmapE `AppE` setter `AppE` (f `AppE` needle)) [ FunD needleN [normalClause [] (VarE fieldName `AppE` a)] @@ -919,24 +933,32 @@ ] mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec] -mkForeignKeysComposite mps t fdef = do +mkForeignKeysComposite mps t ForeignDef {..} = do let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f - let fname = fieldName $ foreignConstraintNameHaskell fdef - let reftableString = unpack $ unHaskellName $ foreignRefTableHaskell fdef + let fname = fieldName foreignConstraintNameHaskell + let reftableString = unpack $ unHaskellName $ foreignRefTableHaskell let reftableKeyName = mkName $ reftableString `mappend` "Key" let tablename = mkName $ unpack $ entityText t recordName <- newName "record" - let fldsE = map (\(a,_,_,_) -> VarE (fieldName a) `AppE` VarE recordName) $ - foreignFields fdef - let mkKeyE = foldl' AppE (ConE reftableKeyName) fldsE + let fldsE = map (\((foreignName, _),_) -> VarE (fieldName $ foreignName) + `AppE` VarE recordName) foreignFields + let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE let fn = FunD fname [normalClause [VarP recordName] mkKeyE] - let t2 = ConT ''Key `AppT` ConT (mkName reftableString) + let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString) let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2 return [sig, fn] +maybeExp :: Bool -> Exp -> Exp +maybeExp may exp | may = fmapE `AppE` exp + | otherwise = exp +maybeTyp :: Bool -> Type -> Type +maybeTyp may typ | may = ConT ''Maybe `AppT` typ + | otherwise = typ + + -- | produce code similar to the following: -- -- @ @@ -1060,10 +1082,10 @@ return $ InstanceD - [ ClassP ''PersistQuery [VarT $ mkName "backend"] - , EqualP (ConT ''PersistEntityBackend `AppT` entityT) (VarT $ mkName "backend") + [ ClassP ''PersistQuery [backendT] + , EqualP (ConT ''PersistEntityBackend `AppT` entityT) backendT ] - (ConT ''DeleteCascade `AppT` entityT `AppT` VarT (mkName "backend")) + (ConT ''DeleteCascade `AppT` entityT `AppT` backendT) [ FunD 'deleteCascade [normalClause [VarP key] (DoE stmts)] ] @@ -1106,7 +1128,7 @@ InstanceD ctx (ConT clazz `AppT` typ) where ctx - | hasBackend = [ClassP ''PersistStore [VarT $ mkName "backend"]] + | hasBackend = [ClassP ''PersistStore [backendT]] | otherwise = [] persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint @@ -1213,28 +1235,28 @@ return $ NoBindS $ m `AppE` defsExp `AppE` u instance Lift EntityDef where - lift (EntityDef a b c d e f g h i j k) = + lift EntityDef{..} = [|EntityDef - $(lift a) - $(lift b) - $(lift c) - $(liftTs d) - $(lift e) - $(lift f) - $(lift g) - $(lift h) - $(liftTs i) - $(liftMap j) - $(lift k) + $(lift entityHaskell) + $(lift entityDB) + $(lift entityID) + $(lift' entityAttrs) + $(lift entityFields) + $(lift entityPrimary) + $(lift entityUniques) + $(lift entityForeigns) + $(lift' entityDerives) + $(lift' entityExtra) + $(lift entitySum) |] instance Lift FieldDef where - lift (FieldDef a b c d e f g) = [|FieldDef a b c $(lift' d) $(liftTs e) f g|] + lift (FieldDef a b c d e f g) = [|FieldDef a b c $(lift' d) $(lift' e) f g|] instance Lift UniqueDef where - lift (UniqueDef a b c d) = [|UniqueDef $(lift a) $(lift b) $(lift c) $(liftTs d)|] + lift (UniqueDef a b c d) = [|UniqueDef $(lift a) $(lift b) $(lift c) $(lift' d)|] instance Lift PrimaryDef where - lift (PrimaryDef a b) = [|PrimaryDef $(lift a) $(liftTs b)|] + lift (PrimaryDef a b) = [|PrimaryDef $(lift a) $(lift' b)|] instance Lift ForeignDef where - lift (ForeignDef a b c d e f) = [|ForeignDef $(lift a) $(lift b) $(lift c) $(lift d) $(lift e) $(liftTs f)|] + lift (ForeignDef a b c d e f g) = [|ForeignDef $(lift a) $(lift b) $(lift c) $(lift d) $(lift e) $(lift' f) $(lift g)|] -- | A hack to avoid orphans. class Lift' a where @@ -1250,7 +1272,14 @@ lift' () = [|()|] instance Lift' SqlTypeExp where lift' = lift +instance Lift' Text where + lift' = liftT +instance Lift' a => Lift' [a] where + lift' xs = do { xs' <- mapM lift' xs; return (ListE xs') } +instance (Lift' k, Lift' v) => Lift' (M.Map k v) where + lift' m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.toList m)|] + packPTH :: String -> Text packPTH = pack #if !MIN_VERSION_text(0, 11, 2) @@ -1260,17 +1289,8 @@ liftT :: Text -> Q Exp liftT t = [|packPTH $(lift (unpack t))|] -liftTs :: [Text] -> Q Exp -liftTs = fmap ListE . mapM liftT - -liftTss :: [[Text]] -> Q Exp -liftTss = fmap ListE . mapM liftTs - -liftMap :: M.Map Text [[Text]] -> Q Exp -liftMap m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.toList m)|] - -liftPair :: (Text, [[Text]]) -> Q Exp -liftPair (t, ts) = [|($(liftT t), $(liftTss ts))|] +liftPair :: (Lift' k, Lift' v) => (k, v) -> Q Exp +liftPair (k, v) = [|($(lift' k), $(lift' v))|] instance Lift HaskellName where lift (HaskellName t) = [|HaskellName $(liftT t)|] @@ -1327,7 +1347,7 @@ mkField mps et cd = do let con = ForallC [] - [EqualP (VarT $ mkName "typ") maybeTyp] + [EqualP (VarT $ mkName "typ") $ maybeIdType mps cd Nothing Nothing] $ NormalC name [] bod <- lift cd let cla = normalClause @@ -1336,17 +1356,10 @@ return (con, cla) where name = filterConName mps et cd - maybeTyp = - if nullable (fieldAttrs cd) == Nullable ByMaybeAttr - then ConT ''Maybe `AppT` typ - else typ - typ = - case foreignReference cd of - Just ft -> - ConT ''Key - `AppT` genericDataType mps ft backendT - Nothing -> ftToType $ fieldType cd +maybeNullable :: FieldDef -> Bool +maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr + filterConName :: MkPersistSettings -> EntityDef -> FieldDef @@ -1414,7 +1427,7 @@ pulls = map toPull $ entityFields def toPull f = InfixE (Just $ VarE obj) - (if nullable (fieldAttrs f) == Nullable ByMaybeAttr then dotColonQE else dotColonE) + (if maybeNullable f then dotColonQE else dotColonE) (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f) case mpsEntityJSON mps of Nothing -> return [toJSONI, fromJSONI] diff --git a/persistent-template.cabal b/persistent-template.cabal --- a/persistent-template.cabal +++ b/persistent-template.cabal @@ -1,5 +1,5 @@ name: persistent-template -version: 2.0.0.3 +version: 2.0.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -17,7 +17,7 @@ library build-depends: base >= 4 && < 5 , template-haskell - , persistent >= 2.0 && < 2.1 + , persistent >= 2.0.1 && < 2.1 , monad-control >= 0.2 && < 0.4 , bytestring >= 0.9 , text >= 0.5