@@ -1,84 +1,122 @@
11-- the Out-of-the-Tarpit example in Haskell and Project:M36
22{-# LANGUAGE DeriveAnyClass #-}
33import ProjectM36.Client
4−import qualified Data.Text as T
5−import ProjectM36.Atom
6−import Data.Proxy
4+import qualified Data.Map as M
5+import qualified Data.Set as S
6+import Data.Maybe
7+import Control.Monad
8+import Data.Monoid
79
8−type Text = T.Text
10+addressAtomType :: AtomType
11+addressAtomType = TextAtomType
912
10−--custom types cannot yet be made due to hardcoding in the Atom Binary implementation
11−type Address = Text
12−type Agent = Text
13−type Name = Text
14−type Price = Double
15−type FileName = Text
16−data RoomType = Kitchen | Bathroom | LivingRoom deriving (Atomable)
17−roomTypeAtomType = atomTypeForProxy (Proxy :: RoomType)
13+nameAtomType :: AtomType
14+nameAtomType = TextAtomType
1815
19−data PriceBand = Low | Medium | High | Premium
20−priceBandAtomType = atomTypeForProxy (Proxy :: PriceBand)
16+priceAtomType :: AtomType
17+priceAtomType = DoubleAtomType
2118
22−data AreaCode = City | Suburban | Rural
23−areaCodeAtomType = atomTypeForProxy (Proxy :: AreaCode)
19+fileNameAtomType :: AtomType
20+fileNameAtomType = TextAtomType
2421
25−data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand
26−speedBandAtomType = atomTypeForProxy (Proxy :: SpeedBand)
22+roomAtomType :: AtomType
23+roomAtomType = ConstructedAtomType "Room" M.empty
2724
25+priceBandAtomType :: AtomType
26+priceBandAtomType = ConstructedAtomType "PriceBand" M.empty
27+
28+areaCodeAtomType :: AtomType
29+areaCodeAtomType = ConstructedAtomType "AreaCode" M.empty
30+
31+speedBandAtomType :: AtomType
32+speedBandAtomType = ConstructedAtomType "SpeedBand" M.empty
2833
2934main :: IO ()
3035main = do
31− let connInfo = InProcessConnectionInfo emptyNotificationCallback
36+ let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []
3237 check x = case x of
3338 Left err -> error (show err)
3439 Right x' -> x'
3540 eConn <- connectProjectM36 connInfo
3641 let conn = check eConn
3742
38− eSessionId <- createSessionAtHead "master" conn
43+ eSessionId <- createSessionAtHead "master" conn
3944 let sessionId = check eSessionId
4045
4146 createSchema sessionId conn
4247
43−createSchema :: Connection -> IO ()
44−createSchema conn = do
48+createSchema :: SessionId -> Connection -> IO ()
49+createSchema sessionId conn = do
4550 let propertyAttrs = [Attribute "address" addressAtomType,
46− Attribute "price" priceAtomType
51+ Attribute "price" priceAtomType,
4752 Attribute "photo" fileNameAtomType,
48− Attribute "dateRegistered" dateAtomType]
53+ Attribute "dateRegistered" DayAtomType]
4954 offerAttrs = [Attribute "address" addressAtomType,
5055 Attribute "offerPrice" priceAtomType,
51− Attribute "offerDate" dateAtomType,
56+ Attribute "offerDate" DayAtomType,
5257 Attribute "bidderName" nameAtomType,
5358 Attribute "bidderAddress" addressAtomType,
54− Attribute "decisionDate" dateAtomType,
55− Attribute "accepted" boolAtomType]
59+ Attribute "decisionDate" DayAtomType,
60+ Attribute "accepted" BoolAtomType]
5661 decisionAttrs = [Attribute "address" addressAtomType,
57− Attribute "offerDate" dateAtomType,
62+ Attribute "offerDate" DayAtomType,
5863 Attribute "bidderName" nameAtomType,
5964 Attribute "bidderAddress" addressAtomType,
60− Attribute "decisionDate" dateAtomType,
61− Attribute "accepted" boolAtomType]
65+ Attribute "decisionDate" DayAtomType,
66+ Attribute "accepted" BoolAtomType]
6267 roomAttrs = [Attribute "address" addressAtomType,
63− Attribute "roomName" stringAtomType,
64− Attribute "width" doubleAtomType,
65− Attribute "breadth" doubleAtomType,
66− Attribute "type" roomTypeAtomType]
68+ Attribute "roomName" TextAtomType,
69+ Attribute "width" DoubleAtomType,
70+ Attribute "breadth" DoubleAtomType,
71+ Attribute "type" roomAtomType]
6772 floorAttrs = [Attribute "address" addressAtomType,
68− Attribute "roomName" stringAtomType,
69− Attribute "floor" intAtomType]
73+ Attribute "roomName" TextAtomType,
74+ Attribute "floor" IntAtomType]
7075 commissionAttrs = [Attribute "priceBand" priceBandAtomType,
7176 Attribute "areaCode" areaCodeAtomType,
7277 Attribute "saleSpeed" speedBandAtomType,
73− Attribute "commission" doubleAtomType]
78+ Attribute "commission" DoubleAtomType]
79+ idKey rvName attrNames = AddInclusionDependency (rvName <> "_key") $ inclusionDependencyForKey (AttributeNames (S.fromList attrNames)) (RelationVariable rvName ())
80+ incDepKeys = map (uncurry idKey)
81+ [("property", ["address"]),
82+ ("offer", ["address", "offerDate", "bidderName", "bidderAddress"]),
83+ ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),
84+ ("room", ["address", "roomName"]),
85+ ("floor", ["address", "roomName"]),
86+ --"commision" misspelled in OotT
87+ ("commission", ["priceBand", "areaCode", "saleSpeed"])
88+ ]
89+ foreignKeys = [("offer_property_fk",
90+ ("offer", ["address"]),
91+ ("property", ["address"])),
92+ ("decision_offer_fk",
93+ ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),
94+ ("offer", ["address", "offerDate", "bidderName", "bidderAddress"])),
95+ ("room_property_fk",
96+ ("room", ["address"]),
97+ ("property", ["address"])),
98+ ("floor_property_fk",
99+ ("floor", ["address"]),
100+ ("property", ["address"]))
101+ ]
102+ attrsL = AttributeNames . S.fromList
103+ makeFk (fkName, (rvA, attrsA), (rvB, attrsB)) = AddInclusionDependency fkName $ InclusionDependency (Project (attrsL attrsA) (RelationVariable rvA ())) (Project (attrsL attrsB) (RelationVariable rvB ()))
104+ incDepForeignKeys = map makeFk foreignKeys
74105 relvarMap = [("property", propertyAttrs),
75106 ("offer", offerAttrs),
76107 ("decision", decisionAttrs),
77108 ("room", roomAttrs),
78109 ("floor", floorAttrs),
79110 ("commission", commissionAttrs)]
80− dbcontextExprs = map (\(name, attrs) -> Define name (attributesFromList attrs)) relvarMap
81− mapM executeDatabaseContextExpr dbcontextExprs
82−
111+ simple_adt tCons dConsList = AddTypeConstructor (ADTypeConstructorDef tCons []) (map (\name -> DataConstructorDef name []) dConsList)
112+ new_adts = map (uncurry simple_adt) [
113+ ("Room", ["Kitchen", "Bathroom", "LivingRoom"]),
114+ ("PriceBand", ["Low", "Medium", "High", "Premium"]),
115+ ("AreaCode", ["City", "Suburban", "Rural"]),
116+ ("SpeedBand", ["VeryFastBand", "FastBand", "MediumBand", "SlowBand"])]
117+ rvDefs = map (\(name, attrs) -> Define name (map NakedAttributeExpr attrs)) relvarMap
118+ mErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)
119+ let errs = catMaybes mErrs
120+ when (length errs > 0) (error (show errs))
83121
84122