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