@@ -1,11 +1,9 @@
11-- the Out-of-the-Tarpit example in Haskell and Project:M36
2−{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
2+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}
33import ProjectM36.Client
44import qualified Data.Map as M
5−import qualified Data.Set as S
65import Data.Maybe
76import Control.Monad
8−import Data.Monoid
97import GHC.Generics
108import Data.Binary
119import Control.DeepSeq
@@ -62,6 +60,7 @@ main = do
6260
6361createSchema :: SessionId -> Connection -> IO ()
6462createSchema sessionId conn = do
63+ --create attributes for relvars
6564 let propertyAttrs = [Attribute "address" addressAtomType,
6665 Attribute "price" priceAtomType,
6766 Attribute "photo" fileNameAtomType,
@@ -91,8 +90,8 @@ createSchema sessionId conn = do
9190 Attribute "areaCode" areaCodeAtomType,
9291 Attribute "saleSpeed" speedBandAtomType,
9392 Attribute "commission" DoubleAtomType]
94− idKey rvName attrNames = AddInclusionDependency (rvName <> "_key") $ inclusionDependencyForKey (AttributeNames (S.fromList attrNames)) (RelationVariable rvName ())
95− incDepKeys = map (uncurry idKey)
93+ --create uniqueness constraints
94+ incDepKeys = map (uncurry databaseContextExprForUniqueKey)
9695 [("property", ["address"]),
9796 ("offer", ["address", "offerDate", "bidderName", "bidderAddress"]),
9897 ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),
@@ -101,6 +100,7 @@ createSchema sessionId conn = do
101100 --"commision" misspelled in OotT
102101 ("commission", ["priceBand", "areaCode", "saleSpeed"])
103102 ]
103+ --create foreign key constraints
104104 foreignKeys = [("offer_property_fk",
105105 ("offer", ["address"]),
106106 ("property", ["address"])),
@@ -114,22 +114,21 @@ createSchema sessionId conn = do
114114 ("floor", ["address"]),
115115 ("property", ["address"]))
116116 ]
117− attrsL = AttributeNames . S.fromList
118− makeFk (fkName, (rvA, attrsA), (rvB, attrsB)) = AddInclusionDependency fkName $ InclusionDependency (Project (attrsL attrsA) (RelationVariable rvA ())) (Project (attrsL attrsB) (RelationVariable rvB ()))
119− incDepForeignKeys = map makeFk foreignKeys
117+ incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys
118+ --define the relvars
120119 relvarMap = [("property", propertyAttrs),
121120 ("offer", offerAttrs),
122121 ("decision", decisionAttrs),
123122 ("room", roomAttrs),
124123 ("floor", floorAttrs),
125124 ("commission", commissionAttrs)]
126− simple_adt tCons dConsList = AddTypeConstructor (ADTypeConstructorDef tCons []) (map (\name -> DataConstructorDef name []) dConsList)
127− new_adts = map (uncurry simple_adt) [
128− ("Room", ["Kitchen", "Bathroom", "LivingRoom"]),
129− ("PriceBand", ["Low", "Medium", "High", "Premium"]),
130− ("AreaCode", ["City", "Suburban", "Rural"]),
131− ("SpeedBand", ["VeryFastBand", "FastBand", "MediumBand", "SlowBand"])]
132− rvDefs = map (\(name, attrs) -> Define name (map NakedAttributeExpr attrs)) relvarMap
125+ rvDefs = map (\(name, attrs) -> Define name (map NakedAttributeExpr attrs)) relvarMap
126+ --create the new algebraic data types
127+ new_adts = [toDatabaseContextExpr (undefined :: Room),
128+ toDatabaseContextExpr (undefined :: PriceBand),
129+ toDatabaseContextExpr (undefined :: AreaCode),
130+ toDatabaseContextExpr (undefined :: SpeedBand)]
131+ --gather up and execute all database updates
133132 mErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)
134133 let errs = catMaybes mErrs
135134 when (length errs > 0) (error (show errs))