1{-# LANGUAGE DeriveGeneric #-} 2{-# LANGUAGE ExistentialQuantification #-} 3{-# LANGUAGE FlexibleInstances #-} 4{-# LANGUAGE GeneralizedNewtypeDeriving #-} 5{-# LANGUAGE MultiParamTypeClasses #-} 6{-# LANGUAGE OverloadedStrings #-} 7{-# LANGUAGE QuasiQuotes #-} 8{-# LANGUAGE TemplateHaskell #-} 9{-# LANGUAGE TypeFamilies #-} 10{-# LANGUAGE UndecidableInstances #-} 11{-# LANGUAGE DerivingStrategies #-} 12{-# LANGUAGE StandaloneDeriving #-} 13 14-- DeriveAnyClass is not actually used by persistent-template 15-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving 16-- This was fixed by using DerivingStrategies to specify newtype deriving should be used. 17-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled. 18-- See https://github.com/yesodweb/persistent/issues/578 19{-# LANGUAGE DeriveAnyClass #-} 20module Main 21 ( 22 -- avoid unused ident warnings 23 module Main 24 ) where 25 26import Control.Applicative (Const (..)) 27import Data.Aeson 28import Data.ByteString.Lazy.Char8 () 29import Data.Functor.Identity (Identity (..)) 30import Data.Text (Text, pack) 31import Test.Hspec 32import Test.Hspec.QuickCheck 33import Test.QuickCheck.Arbitrary 34import Test.QuickCheck.Gen (Gen) 35import GHC.Generics (Generic) 36 37import Database.Persist 38import Database.Persist.Sql 39import Database.Persist.TH 40import TemplateTestImports 41 42 43share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase| 44Person json 45 name Text 46 age Int Maybe 47 foo Foo 48 address Address 49 deriving Show Eq 50Address json 51 street Text 52 city Text 53 zip Int Maybe 54 deriving Show Eq 55NoJson 56 foo Text 57 deriving Show Eq 58|] 59 60-- TODO: Derive Generic at the source site to get this unblocked. 61deriving instance Generic (BackendKey SqlBackend) 62 63share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase| 64Lperson json 65 name Text 66 age Int Maybe 67 address Laddress 68 deriving Show Eq 69Laddress json 70 street Text 71 city Text 72 zip Int Maybe 73 deriving Show Eq 74|] 75 76arbitraryT :: Gen Text 77arbitraryT = pack <$> arbitrary 78 79instance Arbitrary Person where 80 arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary <*> arbitrary 81instance Arbitrary Address where 82 arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary 83 84main :: IO () 85main = hspec $ do 86 describe "JSON serialization" $ do 87 prop "to/from is idempotent" $ \person -> 88 decode (encode person) == Just (person :: Person) 89 it "decode" $ 90 decode "{\"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just 91 (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing) 92 describe "JSON serialization for Entity" $ do 93 let key = PersonKey 0 94 prop "to/from is idempotent" $ \person -> 95 decode (encode (Entity key person)) == Just (Entity key (person :: Person)) 96 it "decode" $ 97 decode "{\"id\": 0, \"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just 98 (Entity key (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing)) 99 it "lens operations" $ do 100 let street1 = "street1" 101 city1 = "city1" 102 city2 = "city2" 103 zip1 = Just 12345 104 address1 = Laddress street1 city1 zip1 105 address2 = Laddress street1 city2 zip1 106 name1 = "name1" 107 age1 = Just 27 108 person1 = Lperson name1 age1 address1 109 person2 = Lperson name1 age1 address2 110 (person1 ^. lpersonAddress) `shouldBe` address1 111 (person1 ^. (lpersonAddress . laddressCity)) `shouldBe` city1 112 (person1 & ((lpersonAddress . laddressCity) .~ city2)) `shouldBe` person2 113 114(&) :: a -> (a -> b) -> b 115x & f = f x 116 117(^.) :: s 118 -> ((a -> Const a b) -> (s -> Const a t)) 119 -> a 120x ^. lens = getConst $ lens Const x 121 122(.~) :: ((a -> Identity b) -> (s -> Identity t)) 123 -> b 124 -> s 125 -> t 126lens .~ val = runIdentity . lens (\_ -> Identity val) 127