persistent-template 1.2.0.6 → 1.3.0
raw patch · 3 files changed
+106/−27 lines, 3 filesdep +unordered-containersdep ~persistent
Dependencies added: unordered-containers
Dependency ranges changed: persistent
Files
- Database/Persist/TH.hs +95/−25
- persistent-template.cabal +3/−2
- test/main.hs +8/−0
Database/Persist/TH.hs view
@@ -18,6 +18,8 @@ , mpsBackend , mpsGeneric , mpsPrefixFields+ , mpsEntityJSON+ , EntityJSON, entityToJSON, entityFromJSON , mkPersistSettings , sqlSettings , sqlOnlySettings@@ -29,13 +31,16 @@ , derivePersistField , persistFieldFromEntity -- * Internal- , pack'+ , packPTH+ , lensPTH ) where import Prelude hiding ((++), take, concat, splitAt)+import qualified Prelude as P import Database.Persist import Database.Persist.Sql (Migration, SqlPersistT, migrate, SqlBackend, PersistFieldSql) import Database.Persist.Quasi+import Language.Haskell.TH.Lib (varE) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Data.Char (toLower, toUpper)@@ -49,6 +54,7 @@ import Data.Maybe (isJust) import Data.Monoid (mappend, mconcat) import qualified Data.Map as M+import qualified Data.HashMap.Strict as HM import Data.Aeson ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object , Value (Object), (.:), (.:?)@@ -179,8 +185,25 @@ -- True. , mpsPrefixFields :: Bool -- ^ Prefix field names with the model name. Default: True.+ , mpsEntityJSON :: Maybe EntityJSON+ -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's+ -- @Nothing@, no instances will be generated. Default:+ --+ -- @+ -- Just EntityJSON+ -- { entityToJSON = 'keyValueEntityToJSON+ -- , entityFromJSON = 'keyValueEntityFromJSON+ -- }+ -- @ } +data EntityJSON = EntityJSON+ { entityToJSON :: Name+ -- ^ Name of the @toJSON@ implementation for @Entity a@.+ , entityFromJSON :: Name+ -- ^ Name of the @fromJSON@ implementation for @Entity a@.+ }+ -- | Create an @MkPersistSettings@ with default values. mkPersistSettings :: Type -- ^ Value for 'mpsBackend' -> MkPersistSettings@@ -188,6 +211,10 @@ { mpsBackend = t , mpsGeneric = True -- FIXME switch default to False in the future , mpsPrefixFields = True+ , mpsEntityJSON = Just EntityJSON+ { entityToJSON = 'keyValueEntityToJSON+ , entityFromJSON = 'keyValueEntityFromJSON+ } } -- | Use the 'SqlPersist' backend.@@ -485,12 +512,12 @@ type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t -lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b-lens sa sbt afb s = fmap (sbt s) (afb $ sa s)+lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) mkLensClauses :: MkPersistSettings -> EntityDef a -> Q [Clause] mkLensClauses mps t = do- lens' <- [|lens|]+ lens' <- [|lensPTH|] getId <- [|entityKey|] setId <- [|\(Entity _ value) key -> Entity key value|] getVal <- [|entityVal|]@@ -551,7 +578,8 @@ fpv <- mkFromPersistValues mps t utv <- mkUniqueToValues $ entityUniques t puk <- mkUniqueKeys t-+ fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t+ fields <- mapM (mkField mps t) $ FieldDef { fieldHaskell = HaskellName "Id" , fieldDB = entityID t@@ -572,9 +600,9 @@ lensClauses <- mkLensClauses mps t - return $ addSyn- [ dataTypeDec mps t- , TySynD (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") [] $+ return $ addSyn $+ dataTypeDec mps t : mconcat fkc `mappend`+ ([ TySynD (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") [] $ ConT ''KeyBackend `AppT` mpsBackend mps `AppT` ConT (mkName nameS) , InstanceD [] clazz $ [ uniqueTypeDec mps t@@ -606,16 +634,38 @@ , FunD 'persistIdField [Clause [] (NormalB $ ConE $ mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") []] , FunD 'fieldLens lensClauses ]- ]+ ]) +mkForeignKeysComposite :: MkPersistSettings -> EntityDef a -> ForeignDef -> Q [Dec]+mkForeignKeysComposite mps t fdef = do+ let fieldName f = mkName $ unpack $ recName mps (unHaskellName $ entityHaskell t) (unHaskellName f)+ let fname=fieldName $ foreignConstraintNameHaskell fdef+ let reftablename=mkName $ unpack $ unHaskellName $ foreignRefTableHaskell fdef + let tablename=mkName $ unpack $ unHaskellName $ entityHaskell t+ entName <- newName "entname"+ + let flds = map (\(a,_,_,_) -> VarE (fieldName a)) $ foreignFields fdef+ let xs = ListE $ map (\a -> AppE (VarE 'toPersistValue) ((AppE a (VarE entName)))) flds+ let fn = FunD fname [Clause [VarP entName] (NormalB (AppE (ConE 'Key) (AppE (ConE 'PersistList) xs))) []]+ + let t2 = ConT ''KeyBackend `AppT` ConT ''SqlBackend `AppT` ConT reftablename+ let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2+ return [sig, fn]++ -- | produce code similar to the following: -- -- instance PersistEntity e => PersistField e where -- toPersistValue = PersistMap $ zip columNames (map toPersistValue . toPersistFields)--- fromPersistValue (PersistMap o) = fromPersistValues $ map (\(_,v) ->--- casefromPersistValue v of--- Left e -> error e--- Right r -> r) o+-- fromPersistValue (PersistMap o) = +-- let columns = HM.fromList x+-- in fromPersistValues $ map (\name ->+-- case HM.lookup name o of+-- Just v ->+-- case fromPersistValue v of+-- Left e -> error e+-- Right r -> r+-- Nothing -> error $ "Missing field: " `mappend` unpack name) columnNames -- fromPersistValue x = Left $ "Expected PersistMap, received: " ++ show x -- sqlType _ = SqlString persistFieldFromEntity :: MkPersistSettings -> EntityDef a -> Q [Dec]@@ -623,9 +673,14 @@ ss <- [|SqlString|] let columnNames = map (unpack . unHaskellName . fieldHaskell) (entityFields e) obj <- [|\ent -> PersistMap $ zip (map pack columnNames) (map toPersistValue $ toPersistFields ent)|]- fpv <- [|\x -> fromPersistValues $ map (\(_,v) -> case fromPersistValue v of- Left e' -> error $ unpack e'- Right r -> r) x|]+ fpv <- [|\x -> let columns = HM.fromList x+ in fromPersistValues $ map (\name -> + case HM.lookup name columns of+ Just v -> + case fromPersistValue v of+ Left e' -> error $ unpack e'+ Right r -> r+ Nothing -> error $ "Missing field: " `mappend` unpack name) (map pack columnNames)|] let typ = genericDataType mps (pack entityName) $ VarT $ mkName "backend" compose <- [|(<=<)|]@@ -836,7 +891,7 @@ return $ NoBindS $ m `AppE` defsExp `AppE` u instance Lift' a => Lift (EntityDef a) where- lift (EntityDef a b c d e f g h i) =+ lift (EntityDef a b c d e f g h i j k) = [|EntityDef $(lift a) $(lift b)@@ -844,14 +899,20 @@ $(liftTs d) $(lift e) $(lift f)- $(liftTs g)- $(liftMap h)- $(lift i)+ $(lift g)+ $(lift h)+ $(liftTs i)+ $(liftMap j)+ $(lift k) |] instance Lift' a => Lift (FieldDef a) where lift (FieldDef a b c d e f g) = [|FieldDef a b c $(lift' d) $(liftTs e) f $(lift' g)|] instance Lift UniqueDef where lift (UniqueDef a b c d) = [|UniqueDef $(lift a) $(lift b) $(lift c) $(liftTs d)|]+instance Lift PrimaryDef where+ lift (PrimaryDef a b) = [|PrimaryDef $(lift a) $(liftTs 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)|] -- | A hack to avoid orphans. class Lift' a where@@ -868,14 +929,14 @@ instance Lift' SqlTypeExp where lift' = lift -pack' :: String -> Text-pack' = pack+packPTH :: String -> Text+packPTH = pack #if !MIN_VERSION_text(0, 11, 2)-{-# NOINLINE pack' #-}+{-# NOINLINE packPTH #-} #endif liftT :: Text -> Q Exp-liftT t = [|pack' $(lift (unpack t))|]+liftT t = [|packPTH $(lift (unpack t))|] liftTs :: [Text] -> Q Exp liftTs = fmap ListE . mapM liftT@@ -1046,4 +1107,13 @@ (Just $ VarE obj) (if nullable (fieldAttrs f) == Nullable ByMaybeAttr then dotColonQE else dotColonE) (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f)- return [toJSONI, fromJSONI]+ case mpsEntityJSON mps of+ Nothing -> return [toJSONI, fromJSONI]+ Just entityJSON -> do+ entityJSONIs <- [d|+ instance ToJSON (Entity $(pure typ)) where+ toJSON = $(varE (entityToJSON entityJSON))+ instance FromJSON (Entity $(pure typ)) where+ parseJSON = $(varE (entityFromJSON entityJSON))+ |]+ return $ toJSONI : fromJSONI : entityJSONIs
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 1.2.0.6+version: 1.3.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -16,13 +16,14 @@ library build-depends: base >= 4 && < 5 , template-haskell- , persistent >= 1.2 && < 1.3+ , persistent >= 1.3 && < 1.4 , monad-control >= 0.2 && < 0.4 , text >= 0.5 , transformers >= 0.2 && < 0.4 , containers , aeson , monad-logger+ , unordered-containers exposed-modules: Database.Persist.TH ghc-options: -Wall if impl(ghc >= 7.4)
test/main.hs view
@@ -9,6 +9,7 @@ import Database.Persist import Database.Persist.TH+import Database.Persist.Types (PersistValue(..)) import Data.Text (Text, pack) import Data.Aeson @@ -49,3 +50,10 @@ it "decode" $ decode "{\"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just (Person "Michael" (Just 27) $ Address "Narkis" "Maalot" Nothing)+ describe "JSON serialization for Entity" $ do+ let key = Key (PersistInt64 0)+ prop "to/from is idempotent" $ \person ->+ decode (encode (Entity key person)) == Just (Entity key (person :: Person))+ it "decode" $+ decode "{\"key\": 0, \"value\": {\"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}}" `shouldBe` Just+ (Entity key (Person "Michael" (Just 27) $ Address "Narkis" "Maalot" Nothing))