@@ -1,84 +1,122 @@
1-- the Out-of-the-Tarpit example in Haskell and Project:M36
1-- the Out-of-the-Tarpit example in Haskell and Project:M36
2{-# LANGUAGE DeriveAnyClass #-}
2{-# LANGUAGE DeriveAnyClass #-}
3import ProjectM36.Client
3import ProjectM36.Client
4−import qualified Data.Text as T
4+import qualified Data.Map as M
5−import ProjectM36.Atom
5+import qualified Data.Set as S
6−import Data.Proxy
8+import Data.Monoid
8−type Text = T.Text
10+addressAtomType :: AtomType
11+addressAtomType = TextAtomType
10−--custom types cannot yet be made due to hardcoding in the Atom Binary implementation
13+nameAtomType :: AtomType
11−type Address = Text
14+nameAtomType = TextAtomType
16−data RoomType = Kitchen | Bathroom | LivingRoom deriving (Atomable)
17−roomTypeAtomType = atomTypeForProxy (Proxy :: RoomType)
19−data PriceBand = Low | Medium | High | Premium
16+priceAtomType :: AtomType
20−priceBandAtomType = atomTypeForProxy (Proxy :: PriceBand)
17+priceAtomType = DoubleAtomType
22−data AreaCode = City | Suburban | Rural
19+fileNameAtomType :: AtomType
23−areaCodeAtomType = atomTypeForProxy (Proxy :: AreaCode)
20+fileNameAtomType = TextAtomType
25−data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand
22+roomAtomType :: AtomType
26−speedBandAtomType = atomTypeForProxy (Proxy :: SpeedBand)
23+roomAtomType = ConstructedAtomType "Room" M.empty
25+priceBandAtomType :: AtomType
26+priceBandAtomType = ConstructedAtomType "PriceBand" M.empty
28+areaCodeAtomType :: AtomType
29+areaCodeAtomType = ConstructedAtomType "AreaCode" M.empty
31+speedBandAtomType :: AtomType
32+speedBandAtomType = ConstructedAtomType "SpeedBand" M.empty
29main :: IO ()
34main :: IO ()
31− let connInfo = InProcessConnectionInfo emptyNotificationCallback
36+ let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []
32 check x = case x of
37 check x = case x of
33 Left err -> error (show err)
38 Left err -> error (show err)
34 Right x' -> x'
39 Right x' -> x'
35 eConn <- connectProjectM36 connInfo
40 eConn <- connectProjectM36 connInfo
36 let conn = check eConn
41 let conn = check eConn
38− eSessionId <- createSessionAtHead "master" conn
43+ eSessionId <- createSessionAtHead "master" conn
39 let sessionId = check eSessionId
44 let sessionId = check eSessionId
41 createSchema sessionId conn
46 createSchema sessionId conn
43−createSchema :: Connection -> IO ()
48+createSchema :: SessionId -> Connection -> IO ()
44−createSchema conn = do
49+createSchema sessionId conn = do
45 let propertyAttrs = [Attribute "address" addressAtomType,
50 let propertyAttrs = [Attribute "address" addressAtomType,
46− Attribute "price" priceAtomType
51+ Attribute "price" priceAtomType,
47 Attribute "photo" fileNameAtomType,
52 Attribute "photo" fileNameAtomType,
48− Attribute "dateRegistered" dateAtomType]
53+ Attribute "dateRegistered" DayAtomType]
49 offerAttrs = [Attribute "address" addressAtomType,
54 offerAttrs = [Attribute "address" addressAtomType,
50 Attribute "offerPrice" priceAtomType,
55 Attribute "offerPrice" priceAtomType,
51− Attribute "offerDate" dateAtomType,
56+ Attribute "offerDate" DayAtomType,
52 Attribute "bidderName" nameAtomType,
57 Attribute "bidderName" nameAtomType,
53 Attribute "bidderAddress" addressAtomType,
58 Attribute "bidderAddress" addressAtomType,
54− Attribute "decisionDate" dateAtomType,
59+ Attribute "decisionDate" DayAtomType,
55− Attribute "accepted" boolAtomType]
60+ Attribute "accepted" BoolAtomType]
56 decisionAttrs = [Attribute "address" addressAtomType,
61 decisionAttrs = [Attribute "address" addressAtomType,
57− Attribute "offerDate" dateAtomType,
62+ Attribute "offerDate" DayAtomType,
58 Attribute "bidderName" nameAtomType,
63 Attribute "bidderName" nameAtomType,
59 Attribute "bidderAddress" addressAtomType,
64 Attribute "bidderAddress" addressAtomType,
60− Attribute "decisionDate" dateAtomType,
65+ Attribute "decisionDate" DayAtomType,
61− Attribute "accepted" boolAtomType]
66+ Attribute "accepted" BoolAtomType]
62 roomAttrs = [Attribute "address" addressAtomType,
67 roomAttrs = [Attribute "address" addressAtomType,
63− Attribute "roomName" stringAtomType,
68+ Attribute "roomName" TextAtomType,
64− Attribute "width" doubleAtomType,
69+ Attribute "width" DoubleAtomType,
65− Attribute "breadth" doubleAtomType,
70+ Attribute "breadth" DoubleAtomType,
66− Attribute "type" roomTypeAtomType]
71+ Attribute "type" roomAtomType]
67 floorAttrs = [Attribute "address" addressAtomType,
72 floorAttrs = [Attribute "address" addressAtomType,
68− Attribute "roomName" stringAtomType,
73+ Attribute "roomName" TextAtomType,
69− Attribute "floor" intAtomType]
74+ Attribute "floor" IntAtomType]
70 commissionAttrs = [Attribute "priceBand" priceBandAtomType,
75 commissionAttrs = [Attribute "priceBand" priceBandAtomType,
71 Attribute "areaCode" areaCodeAtomType,
76 Attribute "areaCode" areaCodeAtomType,
72 Attribute "saleSpeed" speedBandAtomType,
77 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"])
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"])),
96+ ("room", ["address"]),
97+ ("property", ["address"])),
98+ ("floor_property_fk",
99+ ("floor", ["address"]),
100+ ("property", ["address"]))
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
74 relvarMap = [("property", propertyAttrs),
105 relvarMap = [("property", propertyAttrs),
75 ("offer", offerAttrs),
106 ("offer", offerAttrs),
76 ("decision", decisionAttrs),
107 ("decision", decisionAttrs),
77 ("room", roomAttrs),
108 ("room", roomAttrs),
78 ("floor", floorAttrs),
109 ("floor", floorAttrs),
79 ("commission", commissionAttrs)]
110 ("commission", commissionAttrs)]
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"])]
80− dbcontextExprs = map (\(name, attrs) -> Define name (attributesFromList attrs)) relvarMap
117+ rvDefs = map (\(name, attrs) -> Define name (map NakedAttributeExpr attrs)) relvarMap
81− mapM executeDatabaseContextExpr dbcontextExprs
118+ mErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)
82−
119+ let errs = catMaybes mErrs
120+ when (length errs > 0) (error (show errs))