persistent-template 1.3.0 → 1.3.1
raw patch · 3 files changed
+123/−5 lines, 3 filesdep ~transformers
Dependency ranges changed: transformers
Files
- Database/Persist/TH.hs +71/−3
- persistent-template.cabal +2/−1
- test/main.hs +50/−1
Database/Persist/TH.hs view
@@ -19,6 +19,7 @@ , mpsGeneric , mpsPrefixFields , mpsEntityJSON+ , mpsGenerateLenses , EntityJSON, entityToJSON, entityFromJSON , mkPersistSettings , sqlSettings@@ -195,6 +196,12 @@ -- , entityFromJSON = 'keyValueEntityFromJSON -- } -- @+ , mpsGenerateLenses :: !Bool+ -- ^ Instead of generating normal field accessors, generator lens-style accessors.+ --+ -- Default: False+ --+ -- Since 1.3.1 } data EntityJSON = EntityJSON@@ -215,6 +222,7 @@ { entityToJSON = 'keyValueEntityToJSON , entityFromJSON = 'keyValueEntityFromJSON }+ , mpsGenerateLenses = False } -- | Use the 'SqlPersist' backend.@@ -227,11 +235,19 @@ sqlOnlySettings :: MkPersistSettings sqlOnlySettings = sqlSettings { mpsGeneric = False } -recName :: MkPersistSettings -> Text -> Text -> Text-recName mps dt f+recNameNoUnderscore :: MkPersistSettings -> Text -> Text -> Text+recNameNoUnderscore mps dt f | mpsPrefixFields mps = lowerFirst dt ++ upperFirst f | otherwise = lowerFirst f +recName :: MkPersistSettings -> Text -> Text -> Text+recName mps dt f =+ addUnderscore $ recNameNoUnderscore mps dt f+ where+ addUnderscore+ | mpsGenerateLenses mps = ("_" ++)+ | otherwise = id+ lowerFirst :: Text -> Text lowerFirst t = case uncons t of@@ -600,6 +616,8 @@ lensClauses <- mkLensClauses mps t + lenses <- mkLenses mps t+ return $ addSyn $ dataTypeDec mps t : mconcat fkc `mappend` ([ TySynD (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") [] $@@ -634,7 +652,57 @@ , FunD 'persistIdField [Clause [] (NormalB $ ConE $ mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") []] , FunD 'fieldLens lensClauses ]- ])+ ] `mappend` lenses)++mkLenses :: MkPersistSettings -> EntityDef a -> Q [Dec]+mkLenses mps _ | not (mpsGenerateLenses mps) = return []+mkLenses _ ent | entitySum ent = return []+mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do+ let lensName' = recNameNoUnderscore mps (unHaskellName $ entityHaskell ent) (unHaskellName $ fieldHaskell field)+ lensName = mkName $ unpack lensName'+ fieldName = mkName $ unpack $ "_" ++ lensName'+ needleN <- newName "needle"+ setterN <- newName "setter"+ fN <- newName "f"+ aN <- newName "a"+ yN <- newName "y"+ let needle = VarE needleN+ setter = VarE setterN+ f = VarE fN+ a = VarE aN+ y = VarE yN+ fT = mkName "f"+ -- 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 (fieldType field, nullable $ fieldAttrs field)+ bT = pairToType mps backend2 (fieldType field, nullable $ fieldAttrs field)+ mkST backend = genericDataType mps (unHaskellName $ entityHaskell ent) (VarT backend)+ sT = mkST backend1+ tT = mkST backend2+ t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2+ vars = PlainTV fT+ : (if mpsGeneric mps then [PlainTV backend1{-, PlainTV backend2-}] else [])+ return+ [ SigD lensName $ ForallT vars [ClassP ''Functor [VarT fT]] $+ (aT `arrow` (VarT fT `AppT` bT)) `arrow`+ (sT `arrow` (VarT fT `AppT` tT))+ , FunD lensName $ return $ Clause+ [VarP fN, VarP aN]+ (NormalB $ VarE 'fmap+ `AppE` setter+ `AppE` (f `AppE` needle))+ [ FunD needleN [Clause [] (NormalB $ VarE fieldName `AppE` a) []]+ , FunD setterN $ return $ Clause+ [VarP yN]+ (NormalB $ RecUpdE a+ [ (fieldName, y)+ ])+ []+ ]+ ] mkForeignKeysComposite :: MkPersistSettings -> EntityDef a -> ForeignDef -> Q [Dec] mkForeignKeysComposite mps t fdef = do
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 1.3.0+version: 1.3.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -42,6 +42,7 @@ , persistent , bytestring , QuickCheck+ , transformers source-repository head type: git
test/main.hs view
@@ -5,7 +5,8 @@ import Test.Hspec.QuickCheck import Data.ByteString.Lazy.Char8 () import Test.QuickCheck.Arbitrary-import Control.Applicative ((<$>), (<*>))+import Control.Applicative ((<$>), (<*>), Const (..))+import Data.Functor.Identity (Identity (..)) import Database.Persist import Database.Persist.TH@@ -29,6 +30,27 @@ deriving Show Eq |] +share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase|+Lperson json+ name Text+ age Int Maybe+ address Laddress+ deriving Show Eq+Laddress json+ street Text+ city Text+ zip Int Maybe+ deriving Show Eq+|]++share [mkPersist sqlSettings { mpsGeneric = True , mpsGenerateLenses = True }] [persistLowerCase|+Foo+ bar Text Maybe+ baz BazId+Baz+ bin Int+|]+ -- ensure no-json works instance ToJSON NoJson where toJSON = undefined@@ -57,3 +79,30 @@ 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))+ it "lens operations" $ do+ let street1 = "street1"+ city1 = "city1"+ city2 = "city2"+ zip1 = Just 12345+ address1 = Laddress street1 city1 zip1+ address2 = Laddress street1 city2 zip1+ name1 = "name1"+ age1 = Just 27+ person1 = Lperson name1 age1 address1+ person2 = Lperson name1 age1 address2+ (person1 ^. lpersonAddress) `shouldBe` address1+ (person1 ^. (lpersonAddress . laddressCity)) `shouldBe` city1+ (person1 & ((lpersonAddress . laddressCity) .~ city2)) `shouldBe` person2++x & f = f x++(^.) :: s+ -> ((a -> Const a b) -> (s -> Const a t))+ -> a+x ^. lens = getConst $ lens Const x++(.~) :: ((a -> Identity b) -> (s -> Identity t))+ -> b+ -> s+ -> t+lens .~ val = runIdentity . lens (\_ -> Identity val)