git.iko.soy/project-m36
on master help sign in
refactor project file hierarchy and clean up some warnings
2d0842bAgentM
ProjectM36/Atom.hsnew file+4
compare with master
unifiedsplit
@@ -0,0 +1,4 @@
1+module ProjectM36.Atom where
2+--import ProjectM36.Base
3+--import ProjectM36.Attribute
4+
RelationAttribute.hs → ProjectM36/Attribute.hsrenamed+5−5
@@ -1,12 +1,11 @@
1−module RelationAttribute where
1+module ProjectM36.Attribute where
2−import RelationType
2+import ProjectM36.Base
3import qualified Data.Map as M
3import qualified Data.Map as M
4import qualified Data.Set as S
4import qualified Data.Set as S
5import qualified Data.List as L
5import qualified Data.List as L
6−import Debug.Trace
7
6
8renameAttribute :: AttributeName -> Attribute -> Attribute
7renameAttribute :: AttributeName -> Attribute -> Attribute
9−renameAttribute newAttrName (Attribute oldAttrName typeo) = Attribute newAttrName typeo
8+renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo
10
9
11remapWithAttributes :: S.Set AttributeName -> M.Map AttributeName Atom -> M.Map AttributeName Atom
10remapWithAttributes :: S.Set AttributeName -> M.Map AttributeName Atom -> M.Map AttributeName Atom
12remapWithAttributes attrs m = M.intersection m hollowMap
11remapWithAttributes attrs m = M.intersection m hollowMap
@@ -32,12 +31,13 @@ matchingAttributeNameSet = S.intersection
32
31
33
32
34-- this is sorted so the tuples know in which order to output- the ordering is arbitrary
33-- this is sorted so the tuples know in which order to output- the ordering is arbitrary
34+sortedAttributeNameList :: S.Set AttributeName -> [AttributeName]
35sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet
35sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet
36
36
37-- take two attribute sets and return an attribute set with the attributes which do not match
37-- take two attribute sets and return an attribute set with the attributes which do not match
38-- bug: missing attributes don't show up (?)
38-- bug: missing attributes don't show up (?)
39attributesDifference :: Attributes -> Attributes -> Attributes
39attributesDifference :: Attributes -> Attributes -> Attributes
40−attributesDifference attrA attrB = trace (show attrA ++ "\n" ++ show attrB) (M.union mismatchA missingB)
40+attributesDifference attrA attrB = M.union mismatchA missingB
41 where
41 where
42 mismatchA = M.foldrWithKey folder M.empty attrA
42 mismatchA = M.foldrWithKey folder M.empty attrA
43 missingB = M.difference attrA attrB
43 missingB = M.difference attrA attrB
RelationType.hs → ProjectM36/Base.hsrenamed+1−1
@@ -1,5 +1,5 @@
1{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2−module RelationType where
2+module ProjectM36.Base where
3import qualified Data.Map as M
3import qualified Data.Map as M
4import qualified Data.HashSet as HS
4import qualified Data.HashSet as HS
5import qualified Data.Hashable as Hash
5import qualified Data.Hashable as Hash
RelationalError.hs → ProjectM36/Error.hsrenamed+2−4
@@ -1,8 +1,6 @@
1−module RelationalError where
1+module ProjectM36.Error where
2−import RelationType
2+import ProjectM36.Base
3import qualified Data.UUID as U
3import qualified Data.UUID as U
4−import qualified Data.Set as S
5−
6
4
7data RelationalError = NoSuchAttributeNameError String
5data RelationalError = NoSuchAttributeNameError String
8 | TupleAttributeCountMismatchError Int --attribute name
6 | TupleAttributeCountMismatchError Int --attribute name
Relation.hs → ProjectM36/Relation.hsrenamed+43−30
@@ -1,16 +1,16 @@
1-- this is an implementation of the Relation typeclass which creates a GADT DSL
1-- this is an implementation of the Relation typeclass which creates a GADT DSL
2{-# LANGUAGE GADTs,ExistentialQuantification,NoImplicitPrelude #-}
2{-# LANGUAGE GADTs,ExistentialQuantification,NoImplicitPrelude #-}
3−module Relation where
3+module ProjectM36.Relation where
4import qualified Data.Map as M
4import qualified Data.Map as M
5import qualified Data.Set as S
5import qualified Data.Set as S
6import qualified Data.HashSet as HS
6import qualified Data.HashSet as HS
7import Control.Monad
7import Control.Monad
8
8
9−import RelationType
9+import ProjectM36.Base
10−import RelationTuple
10+import ProjectM36.Tuple
11−import RelationAttribute
11+import ProjectM36.Attribute
12−import RelationTupleSet
12+import ProjectM36.TupleSet
13−import RelationalError
13+import ProjectM36.Error
14import Prelude hiding (join)
14import Prelude hiding (join)
15
15
16attributes :: Relation -> Attributes
16attributes :: Relation -> Attributes
@@ -47,10 +47,16 @@ mkRelation attrs tupleSet = do
47 Left err -> Left err
47 Left err -> Left err
48 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
48 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
49
49
50+relationTrue :: Relation
50relationTrue = Relation M.empty $ HS.singleton (RelationTuple M.empty)
51relationTrue = Relation M.empty $ HS.singleton (RelationTuple M.empty)
52+
53+relationFalse :: Relation
51relationFalse = Relation M.empty emptyTupleSet
54relationFalse = Relation M.empty emptyTupleSet
52
55
56+madeTrue :: Either RelationalError Relation
53madeTrue = mkRelation M.empty (HS.fromList [])
57madeTrue = mkRelation M.empty (HS.fromList [])
58+
59+madeFalse :: Either RelationalError Relation
54madeFalse = mkRelation M.empty emptyTupleSet
60madeFalse = mkRelation M.empty emptyTupleSet
55
61
56--used for predicate filtering- instead of allowing for tuple types to be floating around in Tutorial D, just created a "singleton value" relation with cardinality and arity 1 for tuple atom comparison purposes
62--used for predicate filtering- instead of allowing for tuple types to be floating around in Tutorial D, just created a "singleton value" relation with cardinality and arity 1 for tuple atom comparison purposes
@@ -64,7 +70,7 @@ singletonValueFromRelation rel@(Relation _ tupSet) = if cardinality rel /= Count
64 where
70 where
65 value = snd $ head $ M.toList tupMap
71 value = snd $ head $ M.toList tupMap
66 tupMap = tup2Map $ head (HS.toList tupSet)
72 tupMap = tup2Map $ head (HS.toList tupSet)
67− tup2Map (RelationTuple tupMap) = tupMap
73+ tup2Map (RelationTuple tupmap) = tupmap
68
74
69union :: Relation -> Relation -> Either RelationalError Relation
75union :: Relation -> Relation -> Either RelationalError Relation
70union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
76union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
@@ -76,7 +82,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
76 newtuples = HS.union tupSet1 tupSet2
82 newtuples = HS.union tupSet1 tupSet2
77
83
78project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
84project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
79−project projectionAttrNames rel@(Relation oldattrs rtuples) =
85+project projectionAttrNames rel =
80 if not $ attributeNamesContained projectionAttrNames (attributeNames rel)
86 if not $ attributeNamesContained projectionAttrNames (attributeNames rel)
81 then Left $ AttributeNameMismatchError ""
87 then Left $ AttributeNameMismatchError ""
82 else
88 else
@@ -86,10 +92,10 @@ project projectionAttrNames rel@(Relation oldattrs rtuples) =
86 folder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
92 folder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
87 folder tupleToProject acc = case acc of
93 folder tupleToProject acc = case acc of
88 Left err -> Left err
94 Left err -> Left err
89− Right acc -> union acc (Relation newAttrs (HS.singleton (tupleProject projectionAttrNames tupleToProject)))
95+ Right acc2 -> union acc2 (Relation newAttrs (HS.singleton (tupleProject projectionAttrNames tupleToProject)))
90
96
91tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple
97tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple
92−tupleProject projectAttrs tupleIn@(RelationTuple tupleInMap) = RelationTuple $ M.filterWithKey attrFilter tupleInMap
98+tupleProject projectAttrs (RelationTuple tupleInMap) = RelationTuple $ M.filterWithKey attrFilter tupleInMap
93 where
99 where
94 attrFilter key _ = S.member key projectAttrs
100 attrFilter key _ = S.member key projectAttrs
95
101
@@ -141,7 +147,7 @@ group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do
141
147
142--algorithm: self-join with image relation
148--algorithm: self-join with image relation
143group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
149group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
144−group groupAttrNames newAttrName rel@(Relation attrs tupleSet) = do
150+group groupAttrNames newAttrName rel = do
145 nonGroupProjection <- project nonGroupAttrNames rel
151 nonGroupProjection <- project nonGroupAttrNames rel
146 relFold folder (Right $ Relation newAttrs emptyTupleSet) nonGroupProjection
152 relFold folder (Right $ Relation newAttrs emptyTupleSet) nonGroupProjection
147 where
153 where
@@ -150,18 +156,18 @@ group groupAttrNames newAttrName rel@(Relation attrs tupleSet) = do
150 nonGroupAttrNames = nonMatchingAttributeNameSet groupAttrNames (attributeNames rel)
156 nonGroupAttrNames = nonMatchingAttributeNameSet groupAttrNames (attributeNames rel)
151 folder tupleIn acc = case acc of
157 folder tupleIn acc = case acc of
152 Left err -> Left err
158 Left err -> Left err
153− Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleIn (matchingRelTuple tupleIn))))
159+ Right acc2 -> union acc2 (Relation newAttrs (HS.singleton (tupleExtend tupleIn (matchingRelTuple tupleIn))))
154 matchingRelTuple groupTuple = case imageRelationFor groupTuple rel of
160 matchingRelTuple groupTuple = case imageRelationFor groupTuple rel of
155− Right rel -> RelationTuple $ M.singleton newAttrName (RelationAtom rel)
161+ Right rel2 -> RelationTuple $ M.singleton newAttrName (RelationAtom rel2)
156 Left _ -> undefined
162 Left _ -> undefined
157
163
158--help restriction function
164--help restriction function
159--returns a subrelation of
165--returns a subrelation of
160restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
166restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
161−restrictEq (RelationTuple tupMap) rel = restrict filter rel
167+restrictEq (RelationTuple tupMap) rel = restrict rfilter rel
162 where
168 where
163− filter :: RelationTuple -> Bool
169+ rfilter :: RelationTuple -> Bool
164− filter (RelationTuple tupMap2) = M.isSubmapOf tupMap tupMap2
170+ rfilter (RelationTuple tupMap2) = M.isSubmapOf tupMap tupMap2
165
171
166-- unwrap relation-valued attribute
172-- unwrap relation-valued attribute
167-- return error if relval attrs and nongroup attrs overlap
173-- return error if relval attrs and nongroup attrs overlap
@@ -199,12 +205,12 @@ tupleUngroup relvalAttrName newAttrs tuple@(RelationTuple tupMap) = case (tupMap
199
205
200--this is a hack needed because the relation attributes are untyped so we must dig into the relval to get the attribute names
206--this is a hack needed because the relation attributes are untyped so we must dig into the relval to get the attribute names
201attributesForRelval :: AttributeName -> Relation -> Attributes
207attributesForRelval :: AttributeName -> Relation -> Attributes
202−attributesForRelval relvalAttrName relIn@(Relation attrs tupleSet) = attributes relvalRelation
208+attributesForRelval relvalAttrName (Relation _ tupleSet) = attributes relvalRelation
203 where
209 where
204 --this is only temporarily needed until the Relation stores the types of the columns as data- hack alert
210 --this is only temporarily needed until the Relation stores the types of the columns as data- hack alert
205 --find a tuple with attributes to steal to ungroup
211 --find a tuple with attributes to steal to ungroup
206 oneTuple :: RelationTupleSet -> RelationTuple
212 oneTuple :: RelationTupleSet -> RelationTuple
207− oneTuple tupleSet = head $ HS.toList $ HS.filter (\tup@(RelationTuple tupMap) -> M.size tupMap > 0) tupleSet
213+ oneTuple tupSet = head $ HS.toList $ HS.filter (\(RelationTuple tupMap) -> M.size tupMap > 0) tupSet
208 relvalRelation = unsafeRelValFromAtom $ tupleAtomForAttribute (oneTuple tupleSet) relvalAttrName
214 relvalRelation = unsafeRelValFromAtom $ tupleAtomForAttribute (oneTuple tupleSet) relvalAttrName
209 where
215 where
210 unsafeRelValFromAtom :: Atom -> Relation
216 unsafeRelValFromAtom :: Atom -> Relation
@@ -213,7 +219,7 @@ attributesForRelval relvalAttrName relIn@(Relation attrs tupleSet) = attributes
213 unsafeRelValFromAtom (IntAtom _) = undefined
219 unsafeRelValFromAtom (IntAtom _) = undefined
214
220
215restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation
221restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation
216−restrict filter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter filter tupset
222+restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset
217
223
218--joins on columns with the same name- use rename to avoid this- base case: cartesian product
224--joins on columns with the same name- use rename to avoid this- base case: cartesian product
219--after changing from string atoms, there needs to be a type-checking step!
225--after changing from string atoms, there needs to be a type-checking step!
@@ -243,17 +249,18 @@ relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Eith
243relMogrify mapper newAttributes (Relation _ tupSet) = mkRelation newAttributes (HS.map mapper tupSet)
249relMogrify mapper newAttributes (Relation _ tupSet) = mkRelation newAttributes (HS.map mapper tupSet)
244
250
245relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a
251relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a
246−relFold folder acc (Relation attrs tupleSet) = HS.foldr folder acc tupleSet
252+relFold folder acc (Relation _ tupleSet) = HS.foldr folder acc tupleSet
247
253
248--image relation as defined by CJ Date
254--image relation as defined by CJ Date
249--given tupleA and relationB, return restricted relation where tuple attributes are not the attribues in tupleA but are attributes in relationB and match the tuple's value
255--given tupleA and relationB, return restricted relation where tuple attributes are not the attribues in tupleA but are attributes in relationB and match the tuple's value
250
256
251--check that matching attribute names have the same types
257--check that matching attribute names have the same types
252imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
258imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
253−imageRelationFor matchTuple rel@(Relation attrs _) = do
259+imageRelationFor matchTuple rel = do
254 restricted <- restrictEq matchTuple rel --restrict across matching tuples
260 restricted <- restrictEq matchTuple rel --restrict across matching tuples
255 project (nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)) restricted --project across attributes not in rel
261 project (nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)) restricted --project across attributes not in rel
256
262
263+imageRelationTest :: Either RelationalError Relation
257imageRelationTest = imageRelationFor tup s
264imageRelationTest = imageRelationFor tup s
258 where
265 where
259 tup = mkRelationTuple (S.fromList ["SNAME", "CITY", "S#"]) (M.fromList [("SNAME", StringAtom "Smith"), ("S#", StringAtom "S1"), ("CITY", StringAtom "London")])
266 tup = mkRelationTuple (S.fromList ["SNAME", "CITY", "S#"]) (M.fromList [("SNAME", StringAtom "Smith"), ("S#", StringAtom "S1"), ("CITY", StringAtom "London")])
@@ -273,42 +280,48 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe
273
280
274{- C.J. Date's canonical example relvars -}
281{- C.J. Date's canonical example relvars -}
275
282
283+relvarS :: Either RelationalError Relation
276−relvarS = mkRelation attributes tupleSet
284+relvarS = mkRelation attributeSet tupleSet
277 where
285 where
278− attributes = M.fromList [("S#", Attribute "S#" StringAtomType),
286+ attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
279 ("SNAME", Attribute "SNAME" StringAtomType),
287 ("SNAME", Attribute "SNAME" StringAtomType),
280 ("STATUS", Attribute "STATUS" IntAtomType),
288 ("STATUS", Attribute "STATUS" IntAtomType),
281 ("CITY", Attribute "CITY" StringAtomType)]
289 ("CITY", Attribute "CITY" StringAtomType)]
282− tupleSet = HS.fromList $ mkRelationTuples attributes [
290+ tupleSet = HS.fromList $ mkRelationTuples attributeSet [
283 M.fromList [("S#", StringAtom "S1") , ("SNAME", StringAtom "Smith"), ("STATUS", IntAtom 20) , ("CITY", StringAtom "London")],
291 M.fromList [("S#", StringAtom "S1") , ("SNAME", StringAtom "Smith"), ("STATUS", IntAtom 20) , ("CITY", StringAtom "London")],
284 M.fromList [("S#", StringAtom "S2"), ("SNAME", StringAtom "Jones"), ("STATUS", IntAtom 10), ("CITY", StringAtom "Paris")],
292 M.fromList [("S#", StringAtom "S2"), ("SNAME", StringAtom "Jones"), ("STATUS", IntAtom 10), ("CITY", StringAtom "Paris")],
285 M.fromList [("S#", StringAtom "S3"), ("SNAME", StringAtom "Blake"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Paris")],
293 M.fromList [("S#", StringAtom "S3"), ("SNAME", StringAtom "Blake"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Paris")],
286 M.fromList [("S#", StringAtom "S4"), ("SNAME", StringAtom "Clark"), ("STATUS", IntAtom 20), ("CITY", StringAtom "London")],
294 M.fromList [("S#", StringAtom "S4"), ("SNAME", StringAtom "Clark"), ("STATUS", IntAtom 20), ("CITY", StringAtom "London")],
287 M.fromList [("S#", StringAtom "S5"), ("SNAME", StringAtom "Adams"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Athens")]]
295 M.fromList [("S#", StringAtom "S5"), ("SNAME", StringAtom "Adams"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Athens")]]
288
296
297+s :: Relation
289s = case relvarS of { Right r -> r }
298s = case relvarS of { Right r -> r }
290
299
300+relvarP :: Either RelationalError Relation
291−relvarP = mkRelation attributes tupleSet
301+relvarP = mkRelation attributeSet tupleSet
292 where
302 where
293− attributes = M.fromList [("P#", Attribute "P#" StringAtomType),
303+ attributeSet = M.fromList [("P#", Attribute "P#" StringAtomType),
294 ("PNAME", Attribute "PNAME" StringAtomType),
304 ("PNAME", Attribute "PNAME" StringAtomType),
295 ("COLOR", Attribute "COLOR" StringAtomType),
305 ("COLOR", Attribute "COLOR" StringAtomType),
296 ("WEIGHT", Attribute "WEIGHT" StringAtomType),
306 ("WEIGHT", Attribute "WEIGHT" StringAtomType),
297 ("CITY", Attribute "CITY" StringAtomType)]
307 ("CITY", Attribute "CITY" StringAtomType)]
298− tupleSet = HS.fromList $ mkRelationTuples attributes [
308+ tupleSet = HS.fromList $ mkRelationTuples attributeSet [
299 M.fromList [("P#", StringAtom "P1"), ("PNAME", StringAtom "Nut"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "London")]
309 M.fromList [("P#", StringAtom "P1"), ("PNAME", StringAtom "Nut"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "London")]
300 ]
310 ]
311+p :: Relation
301p = case relvarP of { Right r -> r }
312p = case relvarP of { Right r -> r }
302
313
314+relvarSP :: Either RelationalError Relation
303−relvarSP = mkRelation attributes tupleSet
315+relvarSP = mkRelation attributeSet tupleSet
304 where
316 where
305− attributes = M.fromList [("S#", Attribute "S#" StringAtomType),
317+ attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
306 ("P#", Attribute "P#" StringAtomType),
318 ("P#", Attribute "P#" StringAtomType),
307 ("QTY", Attribute "QTY" StringAtomType)]
319 ("QTY", Attribute "QTY" StringAtomType)]
308− tupleSet = HS.fromList $ mkRelationTuples attributes [
320+ tupleSet = HS.fromList $ mkRelationTuples attributeSet [
309 M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P1"), ("QTY", IntAtom 300)]
321 M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P1"), ("QTY", IntAtom 300)]
310 ]
322 ]
311
323
324+sp :: Relation
312sp = case relvarSP of { Right r -> r }
325sp = case relvarSP of { Right r -> r }
313
326
314
327
RelationHTML.hs → ProjectM36/Relation/Show/HTML.hsrenamed+7−7
@@ -1,10 +1,10 @@
1−module RelationHTML where
1+module ProjectM36.Relation.Show.HTML where
2−import RelationType
2+import ProjectM36.Base
3−import Relation
3+import ProjectM36.Relation
4−import RelationTuple
4+import ProjectM36.Tuple
5import qualified Data.HashSet as HS
5import qualified Data.HashSet as HS
6import qualified Data.List as L
6import qualified Data.List as L
7−import RelationAttribute
7+import ProjectM36.Attribute
8
8
9attributesAsHTML :: Attributes -> String
9attributesAsHTML :: Attributes -> String
10attributesAsHTML attrs = "<tr>" ++ (foldr folder "" attrNameList) ++ "</tr>"
10attributesAsHTML attrs = "<tr>" ++ (foldr folder "" attrNameList) ++ "</tr>"
@@ -24,8 +24,8 @@ writeRel :: Relation -> IO ()
24writeRel = writeHTML . relationAsHTML
24writeRel = writeHTML . relationAsHTML
25
25
26atomAsHTML :: Atom -> String
26atomAsHTML :: Atom -> String
27−atomAsHTML (StringAtom s) = s
27+atomAsHTML (StringAtom atom) = atom
28−atomAsHTML (IntAtom i) = show i
28+atomAsHTML (IntAtom int) = show int
29atomAsHTML (RelationAtom rel) = relationAsHTML rel
29atomAsHTML (RelationAtom rel) = relationAsHTML rel
30
30
31tupleAsHTML :: RelationTuple -> String
31tupleAsHTML :: RelationTuple -> String
RelationTerm.hs → ProjectM36/Relation/Show/Term.hsrenamed+9−8
@@ -1,8 +1,8 @@
1--writes Relation to a String suitable for terminal output
1--writes Relation to a String suitable for terminal output
2−module RelationTerm where
2+module ProjectM36.Relation.Show.Term where
3−import RelationType
3+import ProjectM36.Base
4−import RelationTuple
4+import ProjectM36.Tuple
5−import Relation
5+import ProjectM36.Relation
6import qualified Data.Set as S
6import qualified Data.Set as S
7import qualified Data.Map as M
7import qualified Data.Map as M
8import qualified Data.HashSet as HS
8import qualified Data.HashSet as HS
@@ -61,7 +61,7 @@ cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . brea
61 allRows = [header] ++ body
61 allRows = [header] ++ body
62
62
63relationAsTable :: Relation -> Table
63relationAsTable :: Relation -> Table
64−relationAsTable rel@(Relation attributes tupleSet) = (header, body)
64+relationAsTable rel@(Relation _ tupleSet) = (header, body)
65 where
65 where
66 oAttrs = orderedAttributeNames rel
66 oAttrs = orderedAttributeNames rel
67 header = oAttrs
67 header = oAttrs
@@ -70,8 +70,8 @@ relationAsTable rel@(Relation attributes tupleSet) = (header, body)
70 tupleFolder acc (RelationTuple tupMap) = acc ++ [map (\n -> showAtom (tupMap M.! n)) oAttrs]
70 tupleFolder acc (RelationTuple tupMap) = acc ++ [map (\n -> showAtom (tupMap M.! n)) oAttrs]
71
71
72showAtom :: Atom -> String
72showAtom :: Atom -> String
73−showAtom (StringAtom s) = s
73+showAtom (StringAtom atom) = atom
74−showAtom (IntAtom i) = show i
74+showAtom (IntAtom atom) = show atom
75showAtom (RelationAtom rel) = renderTable $ relationAsTable rel
75showAtom (RelationAtom rel) = renderTable $ relationAsTable rel
76
76
77renderTable :: Table -> String
77renderTable :: Table -> String
@@ -122,9 +122,10 @@ showRelation rel
122 | otherwise = renderTable (relationAsTable rel)
122 | otherwise = renderTable (relationAsTable rel)
123
123
124
124
125−simpleExample = s
125+groupedExample :: Relation
126groupedExample = case group (S.fromList ["CITY"]) "CITYREL" s of {Right rel -> rel}
126groupedExample = case group (S.fromList ["CITY"]) "CITYREL" s of {Right rel -> rel}
127
127
128+emptyStringExample :: Relation
128emptyStringExample = case mkRelation attributes tupleSet of
129emptyStringExample = case mkRelation attributes tupleSet of
129 Right x -> x
130 Right x -> x
130 _ -> undefined
131 _ -> undefined
RelationExpr.hs → ProjectM36/RelationalExpression.hsrenamed+53−50
@@ -1,9 +1,9 @@
1−module RelationExpr where
1+module ProjectM36.RelationalExpression where
2−import Relation
2+import ProjectM36.Relation
3−import RelationTuple
3+import ProjectM36.Tuple
4−import RelationTupleSet
4+import ProjectM36.TupleSet
5−import RelationType
5+import ProjectM36.Base
6−import RelationalError
6+import ProjectM36.Error
7import qualified Data.Map as M
7import qualified Data.Map as M
8import qualified Data.HashSet as HS
8import qualified Data.HashSet as HS
9import Control.Monad.State hiding (join)
9import Control.Monad.State hiding (join)
@@ -20,7 +20,7 @@ evalRelationalExpr (RelationVariable name) = do
20evalRelationalExpr (Project attrNameSet expr) = do
20evalRelationalExpr (Project attrNameSet expr) = do
21 rel <- evalRelationalExpr expr
21 rel <- evalRelationalExpr expr
22 case rel of
22 case rel of
23− Right rel -> return $ project attrNameSet rel
23+ Right rel2 -> return $ project attrNameSet rel2
24 Left err -> return $ Left err
24 Left err -> return $ Left err
25
25
26evalRelationalExpr (Union exprA exprB) = do
26evalRelationalExpr (Union exprA exprB) = do
@@ -28,21 +28,21 @@ evalRelationalExpr (Union exprA exprB) = do
28 relB <- evalRelationalExpr exprB
28 relB <- evalRelationalExpr exprB
29 case relA of
29 case relA of
30 Left err -> return $ Left err
30 Left err -> return $ Left err
31− Right relA -> case relB of
31+ Right relA2 -> case relB of
32 Left err -> return $ Left err
32 Left err -> return $ Left err
33− Right relB -> return $ union relA relB
33+ Right relB2 -> return $ union relA2 relB2
34
34
35evalRelationalExpr (Join exprA exprB) = do
35evalRelationalExpr (Join exprA exprB) = do
36 relA <- evalRelationalExpr exprA
36 relA <- evalRelationalExpr exprA
37 relB <- evalRelationalExpr exprB
37 relB <- evalRelationalExpr exprB
38 case relA of
38 case relA of
39 Left err -> return $ Left err
39 Left err -> return $ Left err
40− Right relA -> case relB of
40+ Right relA2 -> case relB of
41 Left err -> return $ Left err
41 Left err -> return $ Left err
42− Right relB -> return $ join relA relB
42+ Right relB2 -> return $ join relA2 relB2
43
43
44−evalRelationalExpr (MakeStaticRelation attributes tupleSet) = do
44+evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do
45− case mkRelation attributes tupleSet of
45+ case mkRelation attributeSet tupleSet of
46 Right rel -> return $ Right rel
46 Right rel -> return $ Right rel
47 Left err -> return $ Left err
47 Left err -> return $ Left err
48
48
@@ -102,31 +102,33 @@ dateExamples = DatabaseContext { inclusionDependencies = HS.empty, -- add foreig
102 products = productsRel
102 products = productsRel
103 supplierProducts = supplierProductsRel
103 supplierProducts = supplierProductsRel
104
104
105+suppliersRel :: Relation
105−suppliersRel = case mkRelation attributes tupleSet of
106+suppliersRel = case mkRelation attributeSet tupleSet of
106− Left err -> undefined
107+ Left _ -> undefined
107 Right rel -> rel
108 Right rel -> rel
108 where
109 where
109− attributes = M.fromList [("S#", Attribute "S#" StringAtomType),
110+ attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
110 ("SNAME", Attribute "SNAME" StringAtomType),
111 ("SNAME", Attribute "SNAME" StringAtomType),
111 ("STATUS", Attribute "STATUS" IntAtomType),
112 ("STATUS", Attribute "STATUS" IntAtomType),
112 ("CITY", Attribute "CITY" StringAtomType)]
113 ("CITY", Attribute "CITY" StringAtomType)]
113− tupleSet = HS.fromList $ mkRelationTuples attributes [
114+ tupleSet = HS.fromList $ mkRelationTuples attributeSet [
114 M.fromList [("S#", StringAtom "S1") , ("SNAME", StringAtom "Smith"), ("STATUS", IntAtom 20) , ("CITY", StringAtom "London")],
115 M.fromList [("S#", StringAtom "S1") , ("SNAME", StringAtom "Smith"), ("STATUS", IntAtom 20) , ("CITY", StringAtom "London")],
115 M.fromList [("S#", StringAtom "S2"), ("SNAME", StringAtom "Jones"), ("STATUS", IntAtom 10), ("CITY", StringAtom "Paris")],
116 M.fromList [("S#", StringAtom "S2"), ("SNAME", StringAtom "Jones"), ("STATUS", IntAtom 10), ("CITY", StringAtom "Paris")],
116 M.fromList [("S#", StringAtom "S3"), ("SNAME", StringAtom "Blake"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Paris")],
117 M.fromList [("S#", StringAtom "S3"), ("SNAME", StringAtom "Blake"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Paris")],
117 M.fromList [("S#", StringAtom "S4"), ("SNAME", StringAtom "Clark"), ("STATUS", IntAtom 20), ("CITY", StringAtom "London")],
118 M.fromList [("S#", StringAtom "S4"), ("SNAME", StringAtom "Clark"), ("STATUS", IntAtom 20), ("CITY", StringAtom "London")],
118 M.fromList [("S#", StringAtom "S5"), ("SNAME", StringAtom "Adams"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Athens")]]
119 M.fromList [("S#", StringAtom "S5"), ("SNAME", StringAtom "Adams"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Athens")]]
119
120
121+productsRel :: Relation
120−productsRel = case mkRelation attributes tupleSet of
122+productsRel = case mkRelation attributeSet tupleSet of
121− Left err -> undefined
123+ Left _ -> undefined
122 Right rel -> rel
124 Right rel -> rel
123 where
125 where
124− attributes = M.fromList [("P#", Attribute "P#" StringAtomType),
126+ attributeSet = M.fromList [("P#", Attribute "P#" StringAtomType),
125 ("PNAME", Attribute "PNAME" StringAtomType),
127 ("PNAME", Attribute "PNAME" StringAtomType),
126 ("COLOR", Attribute "COLOR" StringAtomType),
128 ("COLOR", Attribute "COLOR" StringAtomType),
127 ("WEIGHT", Attribute "WEIGHT" IntAtomType),
129 ("WEIGHT", Attribute "WEIGHT" IntAtomType),
128 ("CITY", Attribute "CITY" StringAtomType)]
130 ("CITY", Attribute "CITY" StringAtomType)]
129− tupleSet = HS.fromList $ mkRelationTuples attributes [
131+ tupleSet = HS.fromList $ mkRelationTuples attributeSet [
130 M.fromList [("P#", StringAtom "P1"), ("PNAME", StringAtom "Nut"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "London")],
132 M.fromList [("P#", StringAtom "P1"), ("PNAME", StringAtom "Nut"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "London")],
131 M.fromList [("P#", StringAtom "P2"), ("PNAME", StringAtom "Bolt"), ("COLOR", StringAtom "Green"), ("WEIGHT", IntAtom 17), ("CITY", StringAtom "Paris")],
133 M.fromList [("P#", StringAtom "P2"), ("PNAME", StringAtom "Bolt"), ("COLOR", StringAtom "Green"), ("WEIGHT", IntAtom 17), ("CITY", StringAtom "Paris")],
132 M.fromList [("P#", StringAtom "P3"), ("PNAME", StringAtom "Screw"), ("COLOR", StringAtom "Blue"), ("WEIGHT", IntAtom 17), ("CITY", StringAtom "Oslo")],
134 M.fromList [("P#", StringAtom "P3"), ("PNAME", StringAtom "Screw"), ("COLOR", StringAtom "Blue"), ("WEIGHT", IntAtom 17), ("CITY", StringAtom "Oslo")],
@@ -135,15 +137,16 @@ productsRel = case mkRelation attributes tupleSet of
135 M.fromList [("P#", StringAtom "P6"), ("PNAME", StringAtom "Cog"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 19), ("CITY", StringAtom "London")]
137 M.fromList [("P#", StringAtom "P6"), ("PNAME", StringAtom "Cog"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 19), ("CITY", StringAtom "London")]
136
138
137 ]
139 ]
138−
140+
139−supplierProductsRel = case mkRelation attributes tupleSet of
141+supplierProductsRel :: Relation
142+supplierProductsRel = case mkRelation attributeSet tupleSet of
140− Left err -> undefined
143+ Left _ -> undefined
141 Right rel -> rel
144 Right rel -> rel
142 where
145 where
143− attributes = M.fromList [("S#", Attribute "S#" StringAtomType),
146+ attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
144 ("P#", Attribute "P#" StringAtomType),
147 ("P#", Attribute "P#" StringAtomType),
145 ("QTY", Attribute "QTY" IntAtomType)]
148 ("QTY", Attribute "QTY" IntAtomType)]
146− tupleSet = HS.fromList $ mkRelationTuples attributes [
149+ tupleSet = HS.fromList $ mkRelationTuples attributeSet [
147 M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P1"), ("QTY", IntAtom 300)],
150 M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P1"), ("QTY", IntAtom 300)],
148 M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P2"), ("QTY", IntAtom 200)],
151 M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P2"), ("QTY", IntAtom 200)],
149 M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P3"), ("QTY", IntAtom 400)],
152 M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P3"), ("QTY", IntAtom 400)],
@@ -164,20 +167,20 @@ supplierProductsRel = case mkRelation attributes tupleSet of
164--helper function to process relation variable creation/assignment
167--helper function to process relation variable creation/assignment
165setRelVar :: String -> Relation -> DatabaseState (Maybe RelationalError)
168setRelVar :: String -> Relation -> DatabaseState (Maybe RelationalError)
166setRelVar relVarName rel = do
169setRelVar relVarName rel = do
167− state <- get
170+ currstate <- get
168− let newRelVars = M.insert relVarName rel $ relationVariables state
171+ let newRelVars = M.insert relVarName rel $ relationVariables currstate
169− case checkConstraints state of
172+ case checkConstraints currstate of
170 Just err -> return $ Just err
173 Just err -> return $ Just err
171 Nothing -> do
174 Nothing -> do
172− put $ DatabaseContext (inclusionDependencies state) newRelVars
175+ put $ DatabaseContext (inclusionDependencies currstate) newRelVars
173 return Nothing
176 return Nothing
174
177
175-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation
178-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation
176deleteRelVar :: String -> DatabaseState (Maybe RelationalError)
179deleteRelVar :: String -> DatabaseState (Maybe RelationalError)
177deleteRelVar relVarName = do
180deleteRelVar relVarName = do
178− state <- get
181+ currstate <- get
179− let newRelVars = M.delete relVarName (relationVariables state)
182+ let newRelVars = M.delete relVarName (relationVariables currstate)
180− put $ DatabaseContext (inclusionDependencies state) newRelVars
183+ put $ DatabaseContext (inclusionDependencies currstate) newRelVars
181 return Nothing
184 return Nothing
182
185
183evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)
186evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)
@@ -217,9 +220,9 @@ evalContextExpr (Delete relVarName predicate) = do
217
220
218--union of restricted+updated portion and the unrestricted+unupdated portion
221--union of restricted+updated portion and the unrestricted+unupdated portion
219evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = do
222evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = do
220− state <- get
223+ currstate <- get
221− let relVarTable = relationVariables state
224+ let relVarTable = relationVariables currstate
222− case predicateRestrictionFilter state restrictionPredicateExpr of
225+ case predicateRestrictionFilter currstate restrictionPredicateExpr of
223 Left err -> return $ Just err
226 Left err -> return $ Just err
224 Right predicateFunc -> do
227 Right predicateFunc -> do
225 case M.lookup relVarName relVarTable of
228 case M.lookup relVarName relVarTable of
@@ -228,18 +231,18 @@ evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = d
228 Left err -> return $ Just err
231 Left err -> return $ Just err
229 Right updatedRel -> setRelVar relVarName updatedRel
232 Right updatedRel -> setRelVar relVarName updatedRel
230 where
233 where
231− makeUpdatedRel rel = do
234+ makeUpdatedRel relin = do
232− restrictedPortion <- restrict predicateFunc rel
235+ restrictedPortion <- restrict predicateFunc relin
233− unrestrictedPortion <- restrict (not . predicateFunc) rel
236+ unrestrictedPortion <- restrict (not . predicateFunc) relin
234 updatedPortion <- relMap tupleUpdater restrictedPortion
237 updatedPortion <- relMap tupleUpdater restrictedPortion
235 union updatedPortion unrestrictedPortion
238 union updatedPortion unrestrictedPortion
236 tupleUpdater = \(RelationTuple tupMap) -> RelationTuple $ M.union attrAssignments tupMap
239 tupleUpdater = \(RelationTuple tupMap) -> RelationTuple $ M.union attrAssignments tupMap
237
240
238
241
239evalContextExpr (AddInclusionDependency dep) = do
242evalContextExpr (AddInclusionDependency dep) = do
240− state <- get
243+ currstate <- get
241− let newDeps = HS.insert dep (inclusionDependencies state)
244+ let newDeps = HS.insert dep (inclusionDependencies currstate)
242− put $ DatabaseContext newDeps (relationVariables state)
245+ put $ DatabaseContext newDeps (relationVariables currstate)
243 return Nothing
246 return Nothing
244
247
245evalContextExpr (MultipleExpr exprs) = do
248evalContextExpr (MultipleExpr exprs) = do
@@ -248,7 +251,7 @@ evalContextExpr (MultipleExpr exprs) = do
248 --some lifting magic needed here
251 --some lifting magic needed here
249 case catMaybes evald of
252 case catMaybes evald of
250 [] -> return $ Nothing
253 [] -> return $ Nothing
251− err:l -> return $ Just err
254+ err:_ -> return $ Just err
252
255
253-- restrict relvar to get affected tuples, update tuples, delete restriction from relvar, relvar = relvar union updated tuples
256-- restrict relvar to get affected tuples, update tuples, delete restriction from relvar, relvar = relvar union updated tuples
254--evalRelVarExpr (Update relVarName updateMap) = do
257--evalRelVarExpr (Update relVarName updateMap) = do
@@ -257,7 +260,7 @@ evalContextExpr (MultipleExpr exprs) = do
257checkConstraints :: DatabaseContext -> Maybe RelationalError
260checkConstraints :: DatabaseContext -> Maybe RelationalError
258checkConstraints context = case failures of
261checkConstraints context = case failures of
259 [] -> Nothing
262 [] -> Nothing
260− l:ls -> Just l
263+ l:_ -> Just l
261 where
264 where
262 failures = catMaybes $ map checkIncDep (HS.toList deps)
265 failures = catMaybes $ map checkIncDep (HS.toList deps)
263 deps = inclusionDependencies context
266 deps = inclusionDependencies context
@@ -292,9 +295,9 @@ checkConstraint (InclusionDependency name subDep superDep) = do
292
295
293typeForRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
296typeForRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
294typeForRelationalExpr expr = do
297typeForRelationalExpr expr = do
295− state <- get
298+ currstate <- get
296 --replace the relationVariables context element with a cloned set of relation devoid of tuples
299 --replace the relationVariables context element with a cloned set of relation devoid of tuples
297− put $ contextWithEmptyTupleSets state
300+ put $ contextWithEmptyTupleSets currstate
298 evalRelationalExpr expr
301 evalRelationalExpr expr
299
302
300--returns a database context with all tuples removed
303--returns a database context with all tuples removed
@@ -315,7 +318,7 @@ predicateRestrictionFilter context (OrPredicate expr1 expr2) = do
315 expr2v <- predicateRestrictionFilter context expr2
318 expr2v <- predicateRestrictionFilter context expr2
316 return $ \x -> expr1v x || expr2v x
319 return $ \x -> expr1v x || expr2v x
317
320
318−predicateRestrictionFilter context TruePredicate = Right $ \x -> True
321+predicateRestrictionFilter _ TruePredicate = Right $ \_ -> True
319
322
320predicateRestrictionFilter context (NotPredicate expr) = do
323predicateRestrictionFilter context (NotPredicate expr) = do
321 exprv <- predicateRestrictionFilter context expr
324 exprv <- predicateRestrictionFilter context expr
@@ -324,13 +327,13 @@ predicateRestrictionFilter context (NotPredicate expr) = do
324predicateRestrictionFilter context (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of
327predicateRestrictionFilter context (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of
325 (Left err, _) -> Left err
328 (Left err, _) -> Left err
326 (Right rel, _) -> if rel == relationTrue then
329 (Right rel, _) -> if rel == relationTrue then
327− Right $ \x -> True
330+ Right $ \_ -> True
328 else if rel == relationFalse then
331 else if rel == relationFalse then
329− Right $ \x -> False
332+ Right $ \_ -> False
330 else
333 else
331 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"
334 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"
332
335
333−predicateRestrictionFilter context (AttributeEqualityPredicate attrName atom) = Right $ \(RelationTuple tupMap) -> tupValue tupMap == atom
336+predicateRestrictionFilter _ (AttributeEqualityPredicate attrName atom) = Right $ \(RelationTuple tupMap) -> tupValue tupMap == atom
334 where
337 where
335 tupValue tupMap = tupMap M.! attrName
338 tupValue tupMap = tupMap M.! attrName
336
339
RelationStaticOptimizer.hs → ProjectM36/StaticOptimizer.hsrenamed+21−22
@@ -1,9 +1,9 @@
1−module RelationStaticOptimizer where
1+module ProjectM36.StaticOptimizer where
2−import RelationType
2+import ProjectM36.Base
3−import RelationExpr
3+import ProjectM36.RelationalExpression
4−import Relation
4+import ProjectM36.Relation
5−import RelationalError
5+import ProjectM36.Error
6−import RelationTupleSet
6+import ProjectM36.TupleSet
7import Control.Monad.State hiding (join)
7import Control.Monad.State hiding (join)
8import Data.Either (rights, lefts)
8import Data.Either (rights, lefts)
9
9
@@ -21,7 +21,7 @@ applyStaticRelationalOptimization (Project attrNameSet expr) = do
21 relType <- typeForRelationalExpr expr
21 relType <- typeForRelationalExpr expr
22 case relType of
22 case relType of
23 Left err -> return $ Left err
23 Left err -> return $ Left err
24− Right relType -> if attributeNames relType == attrNameSet then
24+ Right relType2 -> if attributeNames relType2 == attrNameSet then
25 applyStaticRelationalOptimization expr
25 applyStaticRelationalOptimization expr
26 else do
26 else do
27 optimizedSubExpression <- applyStaticRelationalOptimization expr
27 optimizedSubExpression <- applyStaticRelationalOptimization expr
@@ -44,12 +44,11 @@ applyStaticRelationalOptimization (Union exprA exprB) = do
44applyStaticRelationalOptimization (Join exprA exprB) = do
44applyStaticRelationalOptimization (Join exprA exprB) = do
45 typeA <- typeForRelationalExpr exprA
45 typeA <- typeForRelationalExpr exprA
46 typeB <- typeForRelationalExpr exprB
46 typeB <- typeForRelationalExpr exprB
47− context <- get
48 case typeA of
47 case typeA of
49 Left err -> return $ Left err
48 Left err -> return $ Left err
50− Right typeA -> case typeB of
49+ Right typeA2 -> case typeB of
51 Left err -> return $ Left err
50 Left err -> return $ Left err
52− Right typeB -> if typeA == typeB then --no new attributes to add
51+ Right typeB2 -> if typeA2 == typeB2 then --no new attributes to add
53 return $ Right exprA
52 return $ Right exprA
54 else do
53 else do
55 optExprA <- applyStaticRelationalOptimization exprA
54 optExprA <- applyStaticRelationalOptimization exprA
@@ -57,9 +56,9 @@ applyStaticRelationalOptimization (Join exprA exprB) = do
57
56
58 case optExprA of
57 case optExprA of
59 Left err -> return $ Left err
58 Left err -> return $ Left err
60− Right optExprA -> case optExprB of
59+ Right optExprA2 -> case optExprB of
61 Left err -> return $ Left err
60 Left err -> return $ Left err
62− Right optExprB -> return $ Right (Join optExprA optExprB)
61+ Right optExprB2 -> return $ Right (Join optExprA2 optExprB2)
63
62
64applyStaticRelationalOptimization e@(Rename _ _ _) = return $ Right e
63applyStaticRelationalOptimization e@(Rename _ _ _) = return $ Right e
65
64
@@ -74,9 +73,9 @@ applyStaticRelationalOptimization (Restrict predicate expr) = do
74 optimizedPredicate <- applyStaticPredicateOptimization predicate
73 optimizedPredicate <- applyStaticPredicateOptimization predicate
75 case optimizedPredicate of
74 case optimizedPredicate of
76 Left err -> return $ Left err
75 Left err -> return $ Left err
77− Right optimizedPredicate -> if optimizedPredicate == TruePredicate then
76+ Right optimizedPredicate2 -> if optimizedPredicate2 == TruePredicate then
78 applyStaticRelationalOptimization expr
77 applyStaticRelationalOptimization expr
79− else if optimizedPredicate == NotPredicate TruePredicate then do
78+ else if optimizedPredicate2 == NotPredicate TruePredicate then do
80 attributesRel <- typeForRelationalExpr expr
79 attributesRel <- typeForRelationalExpr expr
81 case attributesRel of
80 case attributesRel of
82 Left err -> return $ Left err
81 Left err -> return $ Left err
@@ -85,7 +84,7 @@ applyStaticRelationalOptimization (Restrict predicate expr) = do
85 optimizedSubExpression <- applyStaticRelationalOptimization expr
84 optimizedSubExpression <- applyStaticRelationalOptimization expr
86 case optimizedSubExpression of
85 case optimizedSubExpression of
87 Left err -> return $ Left err
86 Left err -> return $ Left err
88− Right optSubExpr -> return $ Right $ Restrict optimizedPredicate optSubExpr
87+ Right optSubExpr -> return $ Right $ Restrict optimizedPredicate2 optSubExpr
89
88
90applyStaticRelationalOptimization (Equals exprA exprB) = do
89applyStaticRelationalOptimization (Equals exprA exprB) = do
91 return $ Right $ Equals exprA exprB
90 return $ Right $ Equals exprA exprB
@@ -99,25 +98,25 @@ applyStaticDatabaseOptimization (Assign name expr) = do
99 optimizedExpr <- applyStaticRelationalOptimization expr
98 optimizedExpr <- applyStaticRelationalOptimization expr
100 case optimizedExpr of
99 case optimizedExpr of
101 Left err -> return $ Left err
100 Left err -> return $ Left err
102− Right optimizedExpr -> return $ Right (Assign name optimizedExpr)
101+ Right optimizedExpr2 -> return $ Right (Assign name optimizedExpr2)
103
102
104applyStaticDatabaseOptimization (Insert name expr) = do
103applyStaticDatabaseOptimization (Insert name expr) = do
105 optimizedExpr <- applyStaticRelationalOptimization expr
104 optimizedExpr <- applyStaticRelationalOptimization expr
106 case optimizedExpr of
105 case optimizedExpr of
107 Left err -> return $ Left err
106 Left err -> return $ Left err
108− Right optimizedExpr -> return $ Right (Insert name optimizedExpr)
107+ Right optimizedExpr2 -> return $ Right (Insert name optimizedExpr2)
109
108
110applyStaticDatabaseOptimization (Delete name predicate) = do
109applyStaticDatabaseOptimization (Delete name predicate) = do
111 optimizedPredicate <- applyStaticPredicateOptimization predicate
110 optimizedPredicate <- applyStaticPredicateOptimization predicate
112 case optimizedPredicate of
111 case optimizedPredicate of
113 Left err -> return $ Left err
112 Left err -> return $ Left err
114− Right optimizedPredicate -> return $ Right (Delete name optimizedPredicate)
113+ Right optimizedPredicate2 -> return $ Right (Delete name optimizedPredicate2)
115
114
116−applyStaticDatabaseOptimization (Update name map predicate) = do
115+applyStaticDatabaseOptimization (Update name upmap predicate) = do
117 optimizedPredicate <- applyStaticPredicateOptimization predicate
116 optimizedPredicate <- applyStaticPredicateOptimization predicate
118 case optimizedPredicate of
117 case optimizedPredicate of
119 Left err -> return $ Left err
118 Left err -> return $ Left err
120− Right optimizedPredicate -> return $ Right (Update name map optimizedPredicate)
119+ Right optimizedPredicate2 -> return $ Right (Update name upmap optimizedPredicate2)
121
120
122applyStaticDatabaseOptimization (AddInclusionDependency dep) = return $ Right (AddInclusionDependency dep)
121applyStaticDatabaseOptimization (AddInclusionDependency dep) = return $ Right (AddInclusionDependency dep)
123
122
@@ -136,8 +135,8 @@ applyStaticDatabaseOptimization (MultipleExpr exprs) = do
136 where
135 where
137 substateRunner = forM exprs $ \expr -> do
136 substateRunner = forM exprs $ \expr -> do
138 --a previous expression could create a relvar, we don't want to miss it, so we clear the tuples and execute the expression to get an empty relation in the relvar
137 --a previous expression could create a relvar, we don't want to miss it, so we clear the tuples and execute the expression to get an empty relation in the relvar
139− evalContextExpr expr
138+ _ <- evalContextExpr expr
140− applyStaticDatabaseOptimization expr
139+ applyStaticDatabaseOptimization expr
141 --this error handling could be improved with some lifting presumably
140 --this error handling could be improved with some lifting presumably
142 --restore original context
141 --restore original context
143
142
RelationalTransaction.hs → ProjectM36/Transaction.hsrenamed+12−11
@@ -1,7 +1,7 @@
1−module RelationalTransaction where
1+module ProjectM36.Transaction where
2import qualified Data.UUID as U
2import qualified Data.UUID as U
3−import RelationType
3+import ProjectM36.Base
4−import RelationalError
4+import ProjectM36.Error
5import qualified Data.Set as S
5import qualified Data.Set as S
6import qualified Data.Map as M
6import qualified Data.Map as M
7import Control.Applicative ((<$>))
7import Control.Applicative ((<$>))
@@ -39,7 +39,8 @@ transactionsForUUIDs uuidSet graph = do
39 return (S.fromList transList)
39 return (S.fromList transList)
40
40
41isRootTransaction :: Transaction -> TransactionGraph -> Bool
41isRootTransaction :: Transaction -> TransactionGraph -> Bool
42−isRootTransaction (Transaction _ (TransactionInfo pUUID _) _) graph = U.null pUUID
42+isRootTransaction (Transaction _ (TransactionInfo pUUID _) _) _ = U.null pUUID
43+isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False
43
44
44-- the first transaction has no parent - all other do have parents- merges have two parents
45-- the first transaction has no parent - all other do have parents- merges have two parents
45parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
46parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
@@ -69,17 +70,17 @@ addBranch newBranchName branchPoint graph@(TransactionGraph heads transSet) = if
69-- create a new commit and add it to the heads
70-- create a new commit and add it to the heads
70-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
71-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
71addBranch :: U.UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
72addBranch :: U.UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
72−addBranch newUUID newBranchName branchPoint graph@(TransactionGraph heads transSet) = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph
73+addBranch newUUID newBranchName branchPoint graph = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph
73
74
74--adds a disconnected transaction to a transaction graph at some head
75--adds a disconnected transaction to a transaction graph at some head
75addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
76addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
76−addDisconnectedTransaction newUUID headName dTrans@(DisconnectedTransaction parentUUID context) graph = do
77+addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = do
77 parentTrans <- transactionForUUID parentUUID graph
78 parentTrans <- transactionForUUID parentUUID graph
78 addTransactionToGraph headName parentTrans newUUID context graph
79 addTransactionToGraph headName parentTrans newUUID context graph
79
80
80-- create a new transaction on "newHeadName" with the branchPointTrans
81-- create a new transaction on "newHeadName" with the branchPointTrans
81addTransactionToGraph :: HeadName -> Transaction -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
82addTransactionToGraph :: HeadName -> Transaction -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
82−addTransactionToGraph newHeadName branchPointTrans@(Transaction parentUUID _ parentInfo) newUUID newContext graph@(TransactionGraph heads transSet) = do
83+addTransactionToGraph newHeadName branchPointTrans newUUID newContext (TransactionGraph heads transSet) = do
83 let freshTransaction = Transaction newUUID (TransactionInfo (transactionUUID branchPointTrans) S.empty) newContext
84 let freshTransaction = Transaction newUUID (TransactionInfo (transactionUUID branchPointTrans) S.empty) newContext
84 -- there are two parents for MergeTransactions! not implemented
85 -- there are two parents for MergeTransactions! not implemented
85 --update parentTransaction to add child
86 --update parentTransaction to add child
@@ -89,12 +90,12 @@ addTransactionToGraph newHeadName branchPointTrans@(Transaction parentUUID _ par
89 return (freshTransaction, updatedGraph)
90 return (freshTransaction, updatedGraph)
90
91
91validateGraph :: TransactionGraph -> Maybe [RelationalError]
92validateGraph :: TransactionGraph -> Maybe [RelationalError]
92−validateGraph graph@(TransactionGraph heads transSet) = do
93+validateGraph graph@(TransactionGraph _ transSet) = do
93 --check that all UUIDs are unique in the graph
94 --check that all UUIDs are unique in the graph
94 --uuids = map transactionUUID transSet
95 --uuids = map transactionUUID transSet
95 --check that all heads appear in the transSet
96 --check that all heads appear in the transSet
96 --check that all forward and backward links are in place
97 --check that all forward and backward links are in place
97− errors <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
98+ _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
98 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
99 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
99
100
100--verify that all parent links exist and that all children exist
101--verify that all parent links exist and that all children exist
@@ -113,7 +114,7 @@ walkParentTransactions seenTransSet graph trans =
113 Right parentTransSet -> do
114 Right parentTransSet -> do
114 walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)
115 walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)
115 case walk of
116 case walk of
116− err:xs -> Just err
117+ err:_ -> Just err
117 _ -> Nothing
118 _ -> Nothing
118
119
119--refactor: needless duplication in these two functions
120--refactor: needless duplication in these two functions
@@ -131,6 +132,6 @@ walkChildTransactions seenTransSet graph trans =
131 Right childTransSet -> do
132 Right childTransSet -> do
132 walk <- mapM (walkChildTransactions (S.insert transUUID seenTransSet) graph) (S.toList childTransSet)
133 walk <- mapM (walkChildTransactions (S.insert transUUID seenTransSet) graph) (S.toList childTransSet)
133 case walk of
134 case walk of
134− err:xs -> Just err
135+ err:_ -> Just err
135 _ -> Nothing
136 _ -> Nothing
136
137
RelationalTransactionShow.hs → ProjectM36/Transaction/Show.hsrenamed+12−12
@@ -1,10 +1,10 @@
1−module RelationalTransactionShow where
1+module ProjectM36.Transaction.Show where
2−import RelationType
2+import ProjectM36.Base
3−import Relation
3+import ProjectM36.Relation
4−import RelationTuple
4+import ProjectM36.Tuple
5−import RelationTupleSet
5+import ProjectM36.TupleSet
6−import RelationalError
6+import ProjectM36.Error
7−import RelationalTransaction
7+import ProjectM36.Transaction
8import qualified Data.Map as M
8import qualified Data.Map as M
9import qualified Data.HashSet as HS
9import qualified Data.HashSet as HS
10import qualified Data.Set as S
10import qualified Data.Set as S
@@ -18,17 +18,17 @@ showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID
18 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionUUID) parentTransSet
18 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionUUID) parentTransSet
19
19
20showGraphStructure :: TransactionGraph -> String
20showGraphStructure :: TransactionGraph -> String
21−showGraphStructure graph@(TransactionGraph heads transSet) = S.foldr folder "" transSet
21+showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" transSet
22 where
22 where
23 folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"
23 folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"
24
24
25--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
25--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
26graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
26graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
27−graphAsRelation discon@(DisconnectedTransaction parentUUID _) graph@(TransactionGraph heads transSet) = do
27+graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do
28 tupleSet <- mapM tupleGenerator (S.toList transSet)
28 tupleSet <- mapM tupleGenerator (S.toList transSet)
29− mkRelation attributes (HS.fromList tupleSet)
29+ mkRelation attributeSet (HS.fromList tupleSet)
30 where
30 where
31− attributes = M.fromList [("id", Attribute "id" StringAtomType),
31+ attributeSet = M.fromList [("id", Attribute "id" StringAtomType),
32 ("parents", Attribute "parents" (RelationAtomType parentAttributes)),
32 ("parents", Attribute "parents" (RelationAtomType parentAttributes)),
33 ("current", Attribute "current" IntAtomType),
33 ("current", Attribute "current" IntAtomType),
34 ("head", Attribute "head" StringAtomType)
34 ("head", Attribute "head" StringAtomType)
@@ -56,7 +56,7 @@ transactionParentsRelation trans graph = do
56 mkRelation attributes tupleSet
56 mkRelation attributes tupleSet
57 where
57 where
58 attributes = M.fromList [("id", Attribute "id" StringAtomType)]
58 attributes = M.fromList [("id", Attribute "id" StringAtomType)]
59− trans2tuple trans = mkRelationTuple (S.fromList ["id"]) $ M.singleton "id" (StringAtom (show $ transactionUUID trans))
59+ trans2tuple trans2 = mkRelationTuple (S.fromList ["id"]) $ M.singleton "id" (StringAtom (show $ transactionUUID trans2))
60
60
61
61
62
62
RelationTuple.hs → ProjectM36/Tuple.hsrenamed+6−5
@@ -1,6 +1,7 @@
1−module RelationTuple where
1+module ProjectM36.Tuple where
2−import RelationType
2+import ProjectM36.Base
3−import RelationAttribute
3+import ProjectM36.Attribute
4+
4import qualified Data.Map as M
5import qualified Data.Map as M
5import qualified Data.Set as S
6import qualified Data.Set as S
6import qualified Data.List as L
7import qualified Data.List as L
@@ -37,11 +38,11 @@ tupleRenameAttribute oldattr newattr old@(RelationTuple tmap) =
37
38
38--in case the map does not contain the attributes, filter them out
39--in case the map does not contain the attributes, filter them out
39mkRelationTuple :: S.Set AttributeName-> M.Map AttributeName Atom -> RelationTuple
40mkRelationTuple :: S.Set AttributeName-> M.Map AttributeName Atom -> RelationTuple
40−mkRelationTuple attrs map = RelationTuple newMap
41+mkRelationTuple attrs attrmap = RelationTuple newMap
41 where
42 where
42 --make sure only attributes in the name set are in the tuple
43 --make sure only attributes in the name set are in the tuple
43 --check that Atoms are all of the same type- change to Either return value
44 --check that Atoms are all of the same type- change to Either return value
44− newMap = remapWithAttributes attrs map
45+ newMap = remapWithAttributes attrs attrmap
45
46
46mkRelationTuples :: Attributes -> [M.Map AttributeName Atom] -> [RelationTuple]
47mkRelationTuples :: Attributes -> [M.Map AttributeName Atom] -> [RelationTuple]
47mkRelationTuples attrs maplist = map mapper maplist
48mkRelationTuples attrs maplist = map mapper maplist
RelationTupleSet.hs → ProjectM36/TupleSet.hsrenamed+8−5
@@ -1,13 +1,16 @@
1−module RelationTupleSet where
1+module ProjectM36.TupleSet where
2−import RelationType
2+import ProjectM36.Base
3−import RelationTuple
3+import ProjectM36.Tuple
4−import RelationAttribute
4+import ProjectM36.Attribute
5−import RelationalError
5+import ProjectM36.Error
6import qualified Data.Map as M
6import qualified Data.Map as M
7import qualified Data.HashSet as HS
7import qualified Data.HashSet as HS
8import Control.Monad
8import Control.Monad
9
9
10+emptyTupleSet :: RelationTupleSet
10emptyTupleSet = HS.empty
11emptyTupleSet = HS.empty
12+
13+emptyAttributeSet :: Attributes
11emptyAttributeSet = M.empty
14emptyAttributeSet = M.empty
12
15
13--ensure that all maps have the same keys and key count
16--ensure that all maps have the same keys and key count
RelationAtom.hsdeleted−4
@@ -1,4 +0,0 @@
1−module RelationAtom where
2−import RelationType
3−import RelationAttribute
4−
RelationalInclusionDependency.hsdeleted−5
@@ -1,5 +0,0 @@
1−module RelationalInclusionDependency where
2−import RelationalError
3−import RelationType
4−import Data.Maybe
5−
TutorialDInterpreter.hs → TutorialD/Interpreter.hsrenamed+24−24
@@ -1,15 +1,15 @@
1{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2−module TutorialDInterpreter where
2+module TutorialD.Interpreter where
3−import Relation
3+import ProjectM36.Base
4−import RelationType
4+import ProjectM36.Relation
5−import RelationTuple
5+import ProjectM36.Tuple
6−import RelationTupleSet
6+import ProjectM36.TupleSet
7−import RelationalError
7+import ProjectM36.Error
8−import RelationExpr
8+import ProjectM36.RelationalExpression
9−import RelationTerm
9+import ProjectM36.Relation.Show.Term
10−import RelationStaticOptimizer
10+import ProjectM36.StaticOptimizer
11−import RelationalTransaction
11+import ProjectM36.Transaction
12−import RelationalTransactionShow
12+import ProjectM36.Transaction.Show
13import Text.Parsec
13import Text.Parsec
14import Text.Parsec.String
14import Text.Parsec.String
15import Text.Parsec.Expr
15import Text.Parsec.Expr
@@ -225,8 +225,8 @@ defineP = do
225 relVarName <- identifier
225 relVarName <- identifier
226 reservedOp "::"
226 reservedOp "::"
227 return relVarName
227 return relVarName
228− attributes <- makeAttributes
228+ attributeSet <- makeAttributes
229− return $ Define relVarName attributes
229+ return $ Define relVarName attributeSet
230
230
231undefineP :: Parser DatabaseExpr
231undefineP :: Parser DatabaseExpr
232undefineP = do
232undefineP = do
@@ -320,8 +320,8 @@ showConstraintsP = do
320jumpToHeadP :: Parser GraphOperator
320jumpToHeadP :: Parser GraphOperator
321jumpToHeadP = do
321jumpToHeadP = do
322 reservedOp ":jumphead"
322 reservedOp ":jumphead"
323− head <- identifier
323+ headid <- identifier
324− return $ JumpToHead head
324+ return $ JumpToHead headid
325
325
326jumpToTransactionP :: Parser GraphOperator
326jumpToTransactionP :: Parser GraphOperator
327jumpToTransactionP = do
327jumpToTransactionP = do
@@ -350,6 +350,7 @@ showGraphP = do
350 reservedOp ":showgraph"
350 reservedOp ":showgraph"
351 return $ ShowGraph
351 return $ ShowGraph
352
352
353+transactionGraphOps :: Parser GraphOperator
353transactionGraphOps = do
354transactionGraphOps = do
354 jumpToHeadP
355 jumpToHeadP
355 <|> jumpToTransactionP
356 <|> jumpToTransactionP
@@ -399,21 +400,21 @@ evalContextOp context (ShowConstraint name) = do
399 deps = inclusionDependencies context
400 deps = inclusionDependencies context
400 filteredDeps = case name of
401 filteredDeps = case name of
401 "" -> deps
402 "" -> deps
402− name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
403+ name2 -> HS.filter (\(InclusionDependency n _ _) -> n == name2) deps
403
404
404evalContextOp context (ShowPlan dbExpr) = do
405evalContextOp context (ShowPlan dbExpr) = do
405 DisplayResult $ show plan
406 DisplayResult $ show plan
406 where
407 where
407 plan = evalState (applyStaticDatabaseOptimization dbExpr) context
408 plan = evalState (applyStaticDatabaseOptimization dbExpr) context
408
409
409−evalContextOp context (Quit) = QuitResult
410+evalContextOp _ (Quit) = QuitResult
410
411
411-- returns the new "current" transaction, updated graph, and tutorial d result
412-- returns the new "current" transaction, updated graph, and tutorial d result
412-- the current transaction is not part of the transaction graph until it is committed
413-- the current transaction is not part of the transaction graph until it is committed
413evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
414evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
414
415
415--affects only disconncted transaction
416--affects only disconncted transaction
416−evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
417+evalGraphOp _ _ graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
417 Left err -> Left err
418 Left err -> Left err
418 Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)
419 Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)
419 where
420 where
@@ -421,7 +422,7 @@ evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionF
421
422
422-- switch from one head to another
423-- switch from one head to another
423-- affects only disconnectedtransaction
424-- affects only disconnectedtransaction
424−evalGraphOp newUUID currentTransaction graph (JumpToHead headName) =
425+evalGraphOp _ _ graph (JumpToHead headName) =
425 case transactionForHead headName graph of
426 case transactionForHead headName graph of
426 Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in
427 Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in
427 Right (disconnectedTrans, graph, QuietSuccessResult)
428 Right (disconnectedTrans, graph, QuietSuccessResult)
@@ -441,11 +442,11 @@ evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) gr
441
442
442-- create a new commit and add it to the heads
443-- create a new commit and add it to the heads
443-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
444-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
444−evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
445+evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
445 Left err -> Left err
446 Left err -> Left err
446 Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
447 Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
447 Left err -> Left err
448 Left err -> Left err
448− Right (newTrans, newGraph) -> Right (newDiscon, newGraph, QuietSuccessResult)
449+ Right (_, newGraph) -> Right (newDiscon, newGraph, QuietSuccessResult)
449 where
450 where
450 newDiscon = DisconnectedTransaction newUUID disconContext
451 newDiscon = DisconnectedTransaction newUUID disconContext
451
452
@@ -463,7 +464,7 @@ evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) gra
463 maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
464 maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
464
465
465-- refresh the disconnected transaction, return the same graph
466-- refresh the disconnected transaction, return the same graph
466−evalGraphOp _ discon@(DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
467+evalGraphOp _ (DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
467 Left err -> Left err
468 Left err -> Left err
468 Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)
469 Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)
469 where
470 where
@@ -481,7 +482,6 @@ interpret context tutdstring = case parseString tutdstring of
481 Right parsed -> runState (evaluator parsed) context
482 Right parsed -> runState (evaluator parsed) context
482 where
483 where
483 evaluator expr = do
484 evaluator expr = do
484− context <- get
485 optExpr <- applyStaticDatabaseOptimization expr
485 optExpr <- applyStaticDatabaseOptimization expr
486 --case optExpr of
486 --case optExpr of
487 case optExpr of
487 case optExpr of
@@ -580,5 +580,5 @@ intAtomP = do
580
580
581--used by :dumpGraph
581--used by :dumpGraph
582displayTransactionGraph :: TransactionGraph -> String
582displayTransactionGraph :: TransactionGraph -> String
583−displayTransactionGraph (TransactionGraph heads transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet
583+displayTransactionGraph (TransactionGraph _ transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet
584
584
tutd.hs → TutorialD/tutd.hsrenamed+4−4
@@ -1,7 +1,7 @@
1−import TutorialDInterpreter
1+import TutorialD.Interpreter
2−import RelationExpr
2+import ProjectM36.RelationalExpression
3−import RelationalTransaction
3+import ProjectM36.Transaction
4−import RelationType
4+import ProjectM36.Base
5import Data.UUID.V4 (nextRandom)
5import Data.UUID.V4 (nextRandom)
6
6
7main = do
7main = do
project-m36.cabal+30−7
@@ -6,22 +6,45 @@ Homepage: https://github.com/agentm/project-m36
6Category: Relational Algebra
6Category: Relational Algebra
7Cabal-Version: >= 1.2
7Cabal-Version: >= 1.2
8
8
9−Executable tutd
9+Library
10 Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid
10 Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid
11+ Exposed-Modules: ProjectM36.Error,
12+ ProjectM36.Transaction,
13+ ProjectM36.Transaction.Show,
14+ ProjectM36.Base,
15+ ProjectM36.Attribute,
16+ ProjectM36.Tuple,
17+ ProjectM36.TupleSet,
18+ ProjectM36.Atom,
19+ ProjectM36.RelationalExpression,
20+ ProjectM36.Relation.Show.HTML,
21+ ProjectM36.StaticOptimizer,
22+ ProjectM36.Relation.Show.Term
23+ GHC-Options: -Wall
24+
25+Executable tutd
26+ Build-Depends: base
27+ Other-Modules: ProjectM36.Error,
28+ ProjectM36.Base,
29+ ProjectM36.RelationalExpression,
30+ ProjectM36.Transaction
11− main-is: tutd.hs
31+ main-is: TutorialD/tutd.hs
12− GHC-Options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns
32+ GHC-Options: -Wall
13
33
14Test-Suite test-tutoriald
34Test-Suite test-tutoriald
15 type: exitcode-stdio-1.0
35 type: exitcode-stdio-1.0
16− main-is: TutorialDInterpreterTest.hs
36+ main-is: test/TutorialD/Interpreter.hs
17 Build-Depends: base,HUnit,Cabal
37 Build-Depends: base,HUnit,Cabal
38+ GHC-Options: -Wall
18
39
19Test-Suite test-relation
40Test-Suite test-relation
20 type: exitcode-stdio-1.0
41 type: exitcode-stdio-1.0
21− main-is: RelationTest.hs
42+ main-is: test/Relation/Basic.hs
22 Build-Depends: base,HUnit,Cabal
43 Build-Depends: base,HUnit,Cabal
44+ GHC-Options: -Wall
23
45
24Test-Suite test-static-optimizer
46Test-Suite test-static-optimizer
25 type: exitcode-stdio-1.0
47 type: exitcode-stdio-1.0
26− main-is: RelationStaticOptimizerTest.hs
48+ main-is: test/Relation/StaticOptimizer.hs
27− Build-Depends: base,HUnit,Cabal
49+ Build-Depends: base,HUnit,Cabal
50+ GHC-Options: -Wall
RelationTest.hs → test/Relation/Basic.hsrenamed+5−6
@@ -1,16 +1,15 @@
1import Test.HUnit
1import Test.HUnit
2−import RelationType
2+import ProjectM36.Base
3−import Relation
3+import ProjectM36.Relation
4−import RelationalError
4+import ProjectM36.Error
5−import RelationTuple
5+import ProjectM36.Tuple
6−import RelationTupleSet
6+import ProjectM36.TupleSet
7import qualified Data.Set as S
7import qualified Data.Set as S
8import qualified Data.Map as M
8import qualified Data.Map as M
9import qualified Data.HashSet as HS
9import qualified Data.HashSet as HS
10import System.Exit
10import System.Exit
11import Control.Monad
11import Control.Monad
12
12
13−
14testList = TestList [testRelation relationTrue, testRelation relationFalse,
13testList = TestList [testRelation relationTrue, testRelation relationFalse,
15 testRename1, testRename2]
14 testRename1, testRename2]
16main = do
15main = do
RelationStaticOptimizerTest.hs → test/Relation/StaticOptimizer.hsrenamed+5−5
@@ -1,8 +1,8 @@
1−import RelationType
1+import ProjectM36.Base
2−import Relation
2+import ProjectM36.Relation
3−import RelationExpr
3+import ProjectM36.RelationalExpression
4−import RelationTupleSet
4+import ProjectM36.TupleSet
5−import RelationStaticOptimizer
5+import ProjectM36.StaticOptimizer
6import System.Exit
6import System.Exit
7import Control.Monad.State
7import Control.Monad.State
8import Test.HUnit
8import Test.HUnit
TutorialDInterpreterTest.hs → test/TutorialD/Interpreter.hsrenamed+6−6
@@ -1,10 +1,10 @@
1−import TutorialDInterpreter
1+import TutorialD.Interpreter
2import Test.HUnit
2import Test.HUnit
3−import RelationExpr
3+import ProjectM36.RelationalExpression
4−import Relation
4+import ProjectM36.Relation
5−import RelationalError
5+import ProjectM36.Error
6−import RelationType
6+import ProjectM36.Base
7−import RelationalTransaction
7+import ProjectM36.Transaction
8import qualified Data.HashSet as HS
8import qualified Data.HashSet as HS
9import qualified Data.Map as M
9import qualified Data.Map as M
10import qualified Data.Set as S
10import qualified Data.Set as S