@@ -2,50 +2,35 @@
22{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}
33import ProjectM36.Client
44import ProjectM36.DataTypes.Primitive
5−import qualified Data.Map as M
5+import ProjectM36.Tupleable
66import Data.Either
77import Control.Monad
88import GHC.Generics
99import Data.Binary
1010import Control.DeepSeq
11+import qualified Data.Text as T
12+import Data.Time.Calendar (Day)
13+import qualified Data.Vector as V
1114
1215--create various database value (atom) types
13−addressAtomType :: AtomType
14−addressAtomType = TextAtomType
16+type Price = Double
1517
16−nameAtomType :: AtomType
17−nameAtomType = TextAtomType
18+type Name = T.Text
1819
19−priceAtomType :: AtomType
20−priceAtomType = DoubleAtomType
20+type Address = T.Text
2121
22−fileNameAtomType :: AtomType
23−fileNameAtomType = TextAtomType
24−
25−data Room = Kitchen | Bathroom | LivingRoom
22+data RoomType = Kitchen | Bathroom | LivingRoom
2623 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
2724
28−roomAtomType :: AtomType
29−roomAtomType = toAtomType (undefined :: Room)
30−
3125data PriceBand = Low | Medium | High | Premium
3226 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
3327
34−priceBandAtomType :: AtomType
35−priceBandAtomType = toAtomType (undefined :: PriceBand)
36−
3728data AreaCode = City | Suburban | Rural
3829 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
3930
40−areaCodeAtomType :: AtomType
41−areaCodeAtomType = ConstructedAtomType "AreaCode" M.empty
42−
4331data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand
4432 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
4533
46−speedBandAtomType :: AtomType
47−speedBandAtomType = ConstructedAtomType "SpeedBand" M.empty
48−
4934main :: IO ()
5035main = do
5136 --connect to the database
@@ -62,38 +47,82 @@ main = do
6247
6348 createSchema sessionId conn
6449
50+data Test = Test {
51+ dateo :: Int,
52+ date2o :: Int
53+ }
54+ deriving (Generic, Eq)
55+
56+instance Tupleable Test
57+
58+data Property = Property {
59+ address :: T.Text,
60+ price :: Price,
61+ photo :: T.Text,
62+ dateRegistered :: Day
63+ }
64+ deriving (Generic, Eq)
65+
66+instance Tupleable Property
67+
68+data Offer = Offer {
69+ offerAddress :: Address,
70+ offerPrice :: Price,
71+ offerDate :: Day,
72+ bidderName :: Name,
73+ bidderAddress :: Address,
74+ decisionDate :: Day,
75+ accepted :: Bool
76+ }
77+ deriving (Generic, Eq)
78+
79+instance Tupleable Offer
80+
81+data Decision = Decision {
82+ dec_address :: Address,
83+ dec_offerDate :: Day, --the dec_ prefix is needed until OverloadedRecordFields is available
84+ dec_bidderName :: Name,
85+ dec_bidderAddress :: Address,
86+ dec_decisionDate :: Day,
87+ dec_accepted :: Bool
88+ }
89+ deriving (Generic, Eq)
90+
91+instance Tupleable Decision
92+
93+data Room = Room {
94+ room_address :: Address,
95+ roomName :: Name,
96+ width :: Double,
97+ breadth :: Double,
98+ roomType :: RoomType
99+ }
100+ deriving (Generic, Eq)
101+
102+instance Tupleable Room
103+
104+data Floor = Floor {
105+ floor_address :: Address,
106+ floor_roomName :: Name,
107+ floor :: Int
108+ }
109+ deriving (Generic, Eq)
110+
111+instance Tupleable Floor
112+
113+data Commission = Commission {
114+ priceBand :: PriceBand,
115+ areaCode :: AreaCode,
116+ saleSpeed :: SpeedBand,
117+ commission :: Price
118+ } deriving (Generic, Eq)
119+
120+instance Tupleable Commission
121+
65122createSchema :: SessionId -> Connection -> IO ()
66123createSchema sessionId conn = do
67124 --create attributes for relvars
68− let propertyAttrs = [Attribute "address" addressAtomType,
69− Attribute "price" priceAtomType,
70− Attribute "photo" fileNameAtomType,
71− Attribute "dateRegistered" DayAtomType]
72− offerAttrs = [Attribute "address" addressAtomType,
73− Attribute "offerPrice" priceAtomType,
74− Attribute "offerDate" DayAtomType,
75− Attribute "bidderName" nameAtomType,
76− Attribute "bidderAddress" addressAtomType,
77− Attribute "decisionDate" DayAtomType,
78− Attribute "accepted" BoolAtomType]
79− decisionAttrs = [Attribute "address" addressAtomType,
80− Attribute "offerDate" DayAtomType,
81− Attribute "bidderName" nameAtomType,
82− Attribute "bidderAddress" addressAtomType,
83− Attribute "decisionDate" DayAtomType,
84− Attribute "accepted" BoolAtomType]
85− roomAttrs = [Attribute "address" addressAtomType,
86− Attribute "roomName" TextAtomType,
87− Attribute "width" DoubleAtomType,
88− Attribute "breadth" DoubleAtomType,
89− Attribute "type" roomAtomType]
90− floorAttrs = [Attribute "address" addressAtomType,
91− Attribute "roomName" TextAtomType,
92− Attribute "floor" IntAtomType]
93− commissionAttrs = [Attribute "priceBand" priceBandAtomType,
94− Attribute "areaCode" areaCodeAtomType,
95− Attribute "saleSpeed" speedBandAtomType,
96− Attribute "commission" DoubleAtomType]
125+ let
97126 --create uniqueness constraints
98127 incDepKeys = map (uncurry databaseContextExprForUniqueKey)
99128 [("property", ["address"]),
@@ -120,15 +149,15 @@ createSchema sessionId conn = do
120149 ]
121150 incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys
122151 --define the relvars
123− relvarMap = [("property", propertyAttrs),
124− ("offer", offerAttrs),
125− ("decision", decisionAttrs),
126− ("room", roomAttrs),
127− ("floor", floorAttrs),
128− ("commission", commissionAttrs)]
129− rvDefs = map (\(name, attrs) -> Define name (map NakedAttributeExpr attrs)) relvarMap
152+ relvarMap = [("property", toAttributes (undefined :: Property)),
153+ ("offer", toAttributes (undefined :: Offer)),
154+ ("decision", toAttributes (undefined :: Decision)),
155+ ("room", toAttributes (undefined :: Room)),
156+ ("floor", toAttributes (undefined :: Floor)),
157+ ("commission", toAttributes (undefined :: Commission))]
158+ rvDefs = map (\(name, typ) -> Define name (map NakedAttributeExpr (V.toList typ))) relvarMap
130159 --create the new algebraic data types
131− new_adts = [toDatabaseContextExpr (undefined :: Room),
160+ new_adts = [toDatabaseContextExpr (undefined :: RoomType),
132161 toDatabaseContextExpr (undefined :: PriceBand),
133162 toDatabaseContextExpr (undefined :: AreaCode),
134163 toDatabaseContextExpr (undefined :: SpeedBand)]
@@ -143,8 +172,8 @@ createSchema sessionId conn = do
143172 --gather up and execute all database updates
144173 eErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)
145174 let errs = lefts eErrs
146− unless (null errs) (error (show errs))
175+ unless (null errs) (putStrLn (show errs))
147176
148177 eErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs
149178 let errs' = lefts eErrs'
150− unless (null errs') (error (show errs'))
179+ unless (null errs') (putStrLn (show errs'))