a318000 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

introduce "key" syntax for TutorialD with backing support via inclusion dependencies

a318000AgentM11 years ago

ProjectM36/Base.hs+6−10

compare with master

unifiedsplit

@@ -112,25 +112,20 @@ data RelationalExpr where

112 Ungroup :: AttributeName -> RelationalExpr -> RelationalExpr

113 Restrict :: RestrictionPredicateExpr -> RelationalExpr -> RelationalExpr

114 Equals :: RelationalExpr -> RelationalExpr -> RelationalExpr

115+ NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr

115 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr

116 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr

116 --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend

117 --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend

117 deriving (Show,Eq)

118 deriving (Show,Eq)

118

119

119data DatabaseContext = DatabaseContext {

120data DatabaseContext = DatabaseContext {

120− inclusionDependencies :: HS.HashSet InclusionDependency,

121+ inclusionDependencies :: M.Map IncDepName InclusionDependency,

121− relationVariables :: M.Map RelVarName Relation,

122+ relationVariables :: M.Map RelVarName Relation,

122 atomFunctions :: AtomFunctions

123 atomFunctions :: AtomFunctions

123 } deriving (Show)

124 } deriving (Show)

124

125

125type IncDepName = StringType

126type IncDepName = StringType

126

127

127−data InclusionDependency = InclusionDependency IncDepName RelationalExpr RelationalExpr deriving (Show)

128+data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq)

128−

129−instance Hash.Hashable InclusionDependency where

130− hashWithSalt salt dep = Hash.hashWithSalt salt (show dep)

131−

132−instance Eq InclusionDependency where

133− (==) (InclusionDependency nameA _ _) (InclusionDependency nameB _ _) = nameA == nameB

134

129

135--Database context expressions modify the database context while relational expressions do not

130--Database context expressions modify the database context while relational expressions do not

136data DatabaseExpr where

131data DatabaseExpr where

@@ -140,7 +135,8 @@ data DatabaseExpr where

140 Insert :: RelVarName -> RelationalExpr -> DatabaseExpr

135 Insert :: RelVarName -> RelationalExpr -> DatabaseExpr

141 Delete :: RelVarName -> RestrictionPredicateExpr -> DatabaseExpr

136 Delete :: RelVarName -> RestrictionPredicateExpr -> DatabaseExpr

142 Update :: RelVarName -> M.Map AttributeName Atom -> RestrictionPredicateExpr -> DatabaseExpr -- needs restriction support

137 Update :: RelVarName -> M.Map AttributeName Atom -> RestrictionPredicateExpr -> DatabaseExpr -- needs restriction support

143− AddInclusionDependency :: InclusionDependency -> DatabaseExpr

138+ AddInclusionDependency :: IncDepName -> InclusionDependency -> DatabaseExpr

139+ RemoveInclusionDependency :: IncDepName -> DatabaseExpr

144 MultipleExpr :: [DatabaseExpr] -> DatabaseExpr

140 MultipleExpr :: [DatabaseExpr] -> DatabaseExpr

145 deriving (Show,Eq)

141 deriving (Show,Eq)

146

142

ProjectM36/Error.hs+1

@@ -20,6 +20,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

20 | RelVarAlreadyDefinedError RelVarName

21 | RelVarAssignmentTypeMismatchError Attributes Attributes --expected, found

22 | InclusionDependencyCheckError IncDepName

23+ | InclusionDepedencyNameInUseError IncDepName

23 | ParseError T.Text

24 | ParseError T.Text

24 | PredicateExpressionError T.Text

25 | PredicateExpressionError T.Text

25 | NoSuchTransactionError U.UUID

26 | NoSuchTransactionError U.UUID

ProjectM36/Key.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module ProjectM36.Key where

3+import ProjectM36.Base

4+import ProjectM36.Relation

5+import qualified Data.Set as S

7+{-

8+keys can be implemented using inclusion dependencies as well: the count of the projection of the keys' attributes must be equal to the count of the tuples- p. 120 Database in Depth

10+example:

11+:showexpr ((relation{tuple{}}:{a:=S}):{b:=count(@a)}){b}

12+┌─┐

13+│b│

14+├─┤

15+│5│

16+└─┘

17+((relation{tuple{}}:{a:=S{S#}}):{b:=count(@a)}){b}

18+┌─┐

19+│b│

20+├─┤

21+│5│

22+└─┘

23+-}

24+inclusionDependencyForKey :: AttributeNames -> RelationalExpr -> InclusionDependency

25+inclusionDependencyForKey attrNames relExpr = --InclusionDependency name (exprCount relExpr) (exprCount (projectedOnKeys relExpr))

26+ InclusionDependency equalityExpr (ExistingRelation relationFalse)

27+ where

28+ projectedOnKeys expr = Project attrNames expr

29+ exprAsSubRelation expr = Extend (AttributeTupleExpr "a" (RelationAtomExpr expr)) (ExistingRelation relationTrue)

30+ exprCount expr = projectionForCount (Extend (AttributeTupleExpr "b" (FunctionAtomExpr "count" [AttributeAtomExpr "a"])) (exprAsSubRelation expr))

31+ projectionForCount expr = Project (AttributeNames $ S.fromList ["b"]) expr

32+ equalityExpr = NotEquals (exprCount relExpr) (exprCount (projectedOnKeys relExpr))

33+

ProjectM36/Relation.hs+5−5

@@ -73,12 +73,12 @@ singletonValueFromRelation rel@(Relation _ tupSet) = if cardinality rel /= Count

74union :: Relation -> Relation -> Either RelationalError Relation

75union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

76− if not (attrs1 == attrs2)

76+ if not (A.attributesEqual attrs1 attrs2)

77 then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))

78 else

79 Right $ Relation attrs1 newtuples

80 where

81− newtuples = HS.union tupSet1 tupSet2

81+ newtuples = HS.union tupSet1 (HS.map (reorderTuple attrs1) tupSet2)

83project :: AttributeNames -> Relation -> Either RelationalError Relation

84project projectionAttrNames rel =

@@ -209,8 +209,8 @@ join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do

209 tupleSetJoiner tuple1 accumulator = HS.union (singleTupleSetJoin tuple1 tupSet2) accumulator

210 newAttrs <- A.joinAttributes attrs1 attrs2

211 return $ Relation newAttrs newTupSet

212−

212+

213−--a map should NOT change the structure of a relation, so attributes should be constant

213+--a map should NOT change the structure of a relation, so attributes should be constant

214relMap :: (RelationTuple -> RelationTuple) -> Relation -> Either RelationalError Relation

215relMap mapper (Relation attrs tupleSet) = do

216 case forM (HS.toList tupleSet) typeMapCheck of

@@ -221,7 +221,7 @@ relMap mapper (Relation attrs tupleSet) = do

221 let remappedTuple = mapper tupleIn

222 if tupleAttributes remappedTuple == tupleAttributes tupleIn

223 then Right remappedTuple

224− else Left $ TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs)

224+ else Left $ TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs)

225

226relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation

227relMogrify mapper newAttributes (Relation _ tupSet) = mkRelation newAttributes (HS.map mapper tupSet)

ProjectM36/RelationalExpression.hs+39−16

@@ -89,6 +89,16 @@ evalRelationalExpr (Equals relExprA relExprB) = do

89 Left err -> return $ Left err

90 Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse

92+--warning: copy-pasta from above- refactor

93+evalRelationalExpr (NotEquals relExprA relExprB) = do

94+ evaldA <- evalRelationalExpr relExprA

95+ evaldB <- evalRelationalExpr relExprB

96+ case evaldA of

97+ Left err -> return $ Left err

98+ Right relA -> case evaldB of

99+ Left err -> return $ Left err

100+ Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse

101+

92-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated

102-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated

93evalRelationalExpr (Extend tupleExpression relExpr) = do

103evalRelationalExpr (Extend tupleExpression relExpr) = do

94 evald <- evalRelationalExpr relExpr

104 evald <- evalRelationalExpr relExpr

@@ -101,20 +111,20 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do

101 Right (newAttrs, tupProc) -> return $ relMogrify tupProc newAttrs rel

111 Right (newAttrs, tupProc) -> return $ relMogrify tupProc newAttrs rel

102

112

103emptyDatabaseContext :: DatabaseContext

113emptyDatabaseContext :: DatabaseContext

104−emptyDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

114+emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

105 relationVariables = M.empty,

115 relationVariables = M.empty,

106 atomFunctions = HS.empty

116 atomFunctions = HS.empty

107 }

117 }

108

118

109basicDatabaseContext :: DatabaseContext

119basicDatabaseContext :: DatabaseContext

110−basicDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

120+basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

111 relationVariables = M.fromList [("true", relationTrue),

121 relationVariables = M.fromList [("true", relationTrue),

112 ("false", relationFalse)],

122 ("false", relationFalse)],

113 atomFunctions = basicAtomFunctions

123 atomFunctions = basicAtomFunctions

114 }

124 }

115

125

116dateExamples :: DatabaseContext

126dateExamples :: DatabaseContext

117−dateExamples = DatabaseContext { inclusionDependencies = HS.empty, -- add foreign key relationships

127+dateExamples = DatabaseContext { inclusionDependencies = M.empty,

118 relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,

128 relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,

119 atomFunctions = basicAtomFunctions}

129 atomFunctions = basicAtomFunctions}

120 where

130 where

@@ -186,12 +196,13 @@ productsRel = case mkRelationFromList attrs matrix of

186--helper function to process relation variable creation/assignment

196--helper function to process relation variable creation/assignment

187setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)

197setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)

188setRelVar relVarName rel = do

198setRelVar relVarName rel = do

189− currstate <- get

199+ currentContext <- get

190− let newRelVars = M.insert relVarName rel $ relationVariables currstate

200+ let newRelVars = M.insert relVarName rel $ relationVariables currentContext

201+ let potentialContext = DatabaseContext (inclusionDependencies currentContext) newRelVars (atomFunctions currentContext)

191− case checkConstraints currstate of

202+ case checkConstraints potentialContext of

192 Just err -> return $ Just err

203 Just err -> return $ Just err

193 Nothing -> do

204 Nothing -> do

194− put $ DatabaseContext (inclusionDependencies currstate) newRelVars (atomFunctions currstate)

205+ put potentialContext

195 return Nothing

206 return Nothing

196

207

197-- 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

208-- 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

@@ -258,10 +269,21 @@ evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = d

258 updatedPortion <- relMap (updateTuple attrAssignments) restrictedPortion

269 updatedPortion <- relMap (updateTuple attrAssignments) restrictedPortion

259 union updatedPortion unrestrictedPortion

270 union updatedPortion unrestrictedPortion

260

271

261−evalContextExpr (AddInclusionDependency dep) = do

272+evalContextExpr (AddInclusionDependency newDepName newDep) = do

262− currstate <- get

273+ currContext <- get

263− let newDeps = HS.insert dep (inclusionDependencies currstate)

274+ let currDeps = inclusionDependencies currContext

275+ newDeps = M.insert newDepName newDep currDeps

276+ if M.member newDepName currDeps then

277+ return $ Just (InclusionDepedencyNameInUseError newDepName)

278+ else do

279+ put $ DatabaseContext newDeps (relationVariables currContext) (atomFunctions currContext)

280+ return Nothing

281+

282+evalContextExpr (RemoveInclusionDependency depName) = do

283+ currContext <- get

284+ let currDeps = inclusionDependencies currContext

285+ newDeps = M.delete depName currDeps

264− put $ DatabaseContext newDeps (relationVariables currstate) (atomFunctions currstate)

286+ put $ DatabaseContext newDeps (relationVariables currContext) (atomFunctions currContext)

265 return Nothing

287 return Nothing

266

288

267evalContextExpr (MultipleExpr exprs) = do

289evalContextExpr (MultipleExpr exprs) = do

@@ -281,18 +303,19 @@ checkConstraints context = case failures of

281 [] -> Nothing

303 [] -> Nothing

282 l:_ -> Just l

304 l:_ -> Just l

283 where

305 where

284− failures = catMaybes $ map checkIncDep (HS.toList deps)

306+ failures = M.elems $ M.mapMaybeWithKey checkIncDep deps

285 deps = inclusionDependencies context

307 deps = inclusionDependencies context

286 eval expr = runState (evalRelationalExpr expr) context

308 eval expr = runState (evalRelationalExpr expr) context

287− checkIncDep (InclusionDependency depName subsetExpr supersetExpr) = case evaldSub of

309+ checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = case evaldSub of

288 (Left err, _) -> Just err

310 (Left err, _) -> Just err

289 (Right relSub, _) -> case evaldSuper of

311 (Right relSub, _) -> case evaldSuper of

290 (Left err, _) -> Just err

312 (Left err, _) -> Just err

291 (Right relSuper, _) -> case union relSub relSuper of

313 (Right relSuper, _) -> case union relSub relSuper of

292 Left err -> Just err

314 Left err -> Just err

293− Right resultRel -> case resultRel == relSuper of

315+ Right resultRel -> if resultRel == relSuper then

316+ Nothing

317+ else

294− False -> Just $ InclusionDependencyCheckError depName

318+ Just $ InclusionDependencyCheckError depName

295− True -> Nothing

296 where

319 where

297 evaldSub = eval subsetExpr

320 evaldSub = eval subsetExpr

298 evaldSuper = eval supersetExpr

321 evaldSuper = eval supersetExpr

ProjectM36/StaticOptimizer.hs+5−1

@@ -83,6 +83,8 @@ applyStaticRelationalOptimization (Restrict predicate expr) = do

83 Right optSubExpr -> return $ Right $ Restrict optimizedPredicate2 optSubExpr

85applyStaticRelationalOptimization e@(Equals _ _) = return $ Right e

86+

87+applyStaticRelationalOptimization e@(NotEquals _ _) = return $ Right e

87applyStaticRelationalOptimization e@(Extend _ _) = return $ Right e

89applyStaticRelationalOptimization e@(Extend _ _) = return $ Right e

@@ -115,7 +117,9 @@ applyStaticDatabaseOptimization (Update name upmap predicate) = do

115 Left err -> return $ Left err

117 Left err -> return $ Left err

116 Right optimizedPredicate2 -> return $ Right (Update name upmap optimizedPredicate2)

118 Right optimizedPredicate2 -> return $ Right (Update name upmap optimizedPredicate2)

117

119

118−applyStaticDatabaseOptimization (AddInclusionDependency dep) = return $ Right (AddInclusionDependency dep)

120+applyStaticDatabaseOptimization dep@(AddInclusionDependency _ _) = return $ Right dep

121+

122+applyStaticDatabaseOptimization (RemoveInclusionDependency name) = return $ Right (RemoveInclusionDependency name)

119

123

120--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned

124--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned

121

125

TutorialD/Interpreter/Base.hs−7

@@ -44,13 +44,6 @@ semi = Token.semi lexer

44whiteSpace :: Parser ()

45whiteSpace = Token.whiteSpace lexer

47−--convert Tutorial D type to AtomType

48−tutDTypeToAtomType :: String -> Maybe AtomType

49−tutDTypeToAtomType tutDType = case tutDType of

50− "char" -> Just StringAtomType

51− "int" -> Just IntAtomType

52− _ -> Nothing

53−

54atomTypeToTutDType :: AtomType -> Maybe T.Text

47atomTypeToTutDType :: AtomType -> Maybe T.Text

55atomTypeToTutDType atomType = case atomType of

48atomTypeToTutDType atomType = case atomType of

56 StringAtomType -> Just "char"

49 StringAtomType -> Just "char"

TutorialD/Interpreter/DatabaseExpr.hs+14−1

@@ -1,3 +1,4 @@

1+{-# LANGUAGE OverloadedStrings #-}

1module TutorialD.Interpreter.DatabaseExpr where

2module TutorialD.Interpreter.DatabaseExpr where

2import Text.Parsec

3import Text.Parsec

3import Text.Parsec.String

4import Text.Parsec.String

@@ -11,6 +12,7 @@ import Control.Monad.State

11import ProjectM36.StaticOptimizer

12import ProjectM36.StaticOptimizer

12import ProjectM36.Error

13import ProjectM36.Error

13import ProjectM36.RelationalExpression

14import ProjectM36.RelationalExpression

15+import ProjectM36.Key

15--parsers which create "database expressions" which modify the database context (such as relvar assignment)

17--parsers which create "database expressions" which modify the database context (such as relvar assignment)

16databaseExprP :: Parser DatabaseExpr

18databaseExprP :: Parser DatabaseExpr

@@ -18,6 +20,7 @@ databaseExprP = insertP

18 <|> deleteP

20 <|> deleteP

19 <|> updateP

21 <|> updateP

20 <|> constraintP

22 <|> constraintP

23+ <|> keyP

21 <|> defineP

24 <|> defineP

22 <|> undefineP

25 <|> undefineP

23 <|> assignP

26 <|> assignP

@@ -80,7 +83,17 @@ constraintP = do

80 subset <- relExprP

83 subset <- relExprP

81 reservedOp "in"

84 reservedOp "in"

82 superset <- relExprP

85 superset <- relExprP

83− return $ AddInclusionDependency (InclusionDependency (T.pack constraintName) subset superset)

86+ return $ AddInclusionDependency (T.pack constraintName) (InclusionDependency subset superset)

87+

88+-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>

89+keyP :: Parser DatabaseExpr

90+keyP = do

91+ reserved "key"

92+ keyName <- identifier

93+ uniquenessAttrNames <- braces attributeListP

94+ uniquenessExpr <- relExprP

95+ let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr

96+ return $ AddInclusionDependency (T.pack keyName) newIncDep

85attributeAssignmentP :: Parser (String, Atom)

98attributeAssignmentP :: Parser (String, Atom)

86attributeAssignmentP = do

99attributeAssignmentP = do

TutorialD/Interpreter/RODatabaseContextOperator.hs+7−6

@@ -11,8 +11,8 @@ import TutorialD.Interpreter.RelationalExpr

11import TutorialD.Interpreter.DatabaseExpr

12import Control.Monad.State

13import qualified Data.Text as T

14−import qualified Data.HashSet as HS

15import ProjectM36.Relation.Show.Term

14import ProjectM36.Relation.Show.Term

15+import qualified Data.Map as M

17--operators which only rely on database context reading

18data RODatabaseContextOperator where

@@ -69,13 +69,14 @@ evalRODatabaseContextOp context (ShowRelation expr) = do

69 (Left err, _) -> DisplayErrorResult $ T.pack (show err)

70 (Right rel, _) -> DisplayResult $ showRelation rel

72−evalRODatabaseContextOp context (ShowConstraint name) = do

72+evalRODatabaseContextOp context (ShowConstraint name) =

73+ case name of

74+ "" -> DisplayResult $ T.pack (show deps)

75+ depName -> case M.lookup depName deps of

76+ Nothing -> DisplayErrorResult "No such constraint."

73− DisplayResult $ T.pack (show filteredDeps)

77+ Just dep -> DisplayResult $ T.pack (show dep)

74 where

78 where

75 deps = inclusionDependencies context

79 deps = inclusionDependencies context

76− filteredDeps = case name of

77− "" -> deps

78− name2 -> HS.filter (\(InclusionDependency n _ _) -> n == name2) deps

80evalRODatabaseContextOp context (ShowPlan dbExpr) = do

81evalRODatabaseContextOp context (ShowPlan dbExpr) = do

81 DisplayResult $ T.pack (show plan)

82 DisplayResult $ T.pack (show plan)

TutorialD/Interpreter/RelationalExpr.hs+35−22

@@ -8,6 +8,7 @@ import qualified Data.Text as T

8import qualified ProjectM36.Attribute as A

9import ProjectM36.TupleSet

10import ProjectM36.Tuple

11+import ProjectM36.Relation

11import qualified Data.HashSet as HS

12import qualified Data.HashSet as HS

12import ProjectM36.Atom

13import ProjectM36.Atom

13import qualified Data.Vector as V

14import qualified Data.Vector as V

@@ -15,6 +16,12 @@ import qualified Data.Set as S

15import Control.Applicative (liftA, (<*), (*>), (<$>))

16import Control.Applicative (liftA, (<*), (*>), (<$>))

16import Data.Functor.Identity (Identity)

17import Data.Functor.Identity (Identity)

19+

20+atomTypeP :: Parser AtomType

21+atomTypeP = (reserved "char" *> return StringAtomType) <|>

22+ (reserved "int" *> return IntAtomType) <|>

23+ (RelationAtomType <$> (reserved "relation" *> makeAttributesP))

24+

18--used in projection

25--used in projection

19attributeListP :: Parser AttributeNames

26attributeListP :: Parser AttributeNames

20attributeListP = do

27attributeListP = do

@@ -24,14 +31,7 @@ attributeListP = do

24 return $ constructor (S.fromList (map T.pack attrs))

31 return $ constructor (S.fromList (map T.pack attrs))

26makeRelationP :: Parser RelationalExpr

33makeRelationP :: Parser RelationalExpr

27−makeRelationP = do

34+makeRelationP = ExistingRelation <$> relationP

28− reservedOp "relation"

29− attrs <- (try makeAttributesP <|> return A.emptyAttributes)

30− if not (A.null attrs) then do

31− return $ MakeStaticRelation attrs emptyTupleSet

32− else do

33− tuples <- braces (sepBy tupleP comma)

34− return $ MakeStaticRelation (tupleAttributes (head tuples)) (HS.fromList tuples)

36--used in relation creation

37makeAttributesP :: Parser Attributes

@@ -42,11 +42,9 @@ makeAttributesP = do

42attributeAndTypeP :: Parser Attribute

43attributeAndTypeP = do

44 attrName <- identifier

45− attrTypeName <- identifier

46 --convert type name into type

45 --convert type name into type

47− case tutDTypeToAtomType attrTypeName of

46+ atomType <- atomTypeP

48− Just t -> return $ Attribute (T.pack attrName) t

47+ return $ Attribute (T.pack attrName) atomType

49− Nothing -> fail (attrTypeName ++ " is not a valid type name.")

51tupleP :: Parser RelationTuple

49tupleP :: Parser RelationTuple

52tupleP = do

50tupleP = do

@@ -59,15 +57,9 @@ tupleP = do

59tupleAtomP :: Parser (AttributeName, Atom)

57tupleAtomP :: Parser (AttributeName, Atom)

60tupleAtomP = do

58tupleAtomP = do

61 attributeName <- identifier

59 attributeName <- identifier

62− attrType <- identifier

60+ atom <- atomP

63− atom <- parens (stringAtomP <|> intAtomP)

64− case tutDTypeToAtomType attrType of

65− Nothing -> fail (attrType ++ " is not a valid type name.")

66− Just typeA -> if typeA == atomTypeForAtom atom then

67− return $ (T.pack attributeName, atom)

61+ return $ (T.pack attributeName, atom)

68− else

62+

69− fail "type mismatch in tuple generation"

70−

71projectP :: Parser (RelationalExpr -> RelationalExpr)

63projectP :: Parser (RelationalExpr -> RelationalExpr)

72projectP = do

64projectP = do

73 attrs <- braces attributeListP

65 attrs <- braces attributeListP

@@ -226,7 +218,10 @@ attributeAtomExprP = do

226 return $ AttributeAtomExpr (T.pack attrName)

218 return $ AttributeAtomExpr (T.pack attrName)

227

219

228nakedAtomExprP :: Parser AtomExpr

220nakedAtomExprP :: Parser AtomExpr

229−nakedAtomExprP = NakedAtomExpr <$> (stringAtomP <|> intAtomP <|> boolAtomP)

221+nakedAtomExprP = NakedAtomExpr <$> atomP

222+

223+atomP :: Parser Atom

224+atomP = stringAtomP <|> intAtomP <|> boolAtomP <|> relationAtomP

230

225

231functionAtomExprP :: Parser AtomExpr

226functionAtomExprP :: Parser AtomExpr

232functionAtomExprP = do

227functionAtomExprP = do

@@ -253,4 +248,22 @@ boolAtomP :: Parser Atom

253boolAtomP = do

248boolAtomP = do

254 val <- char 't' <|> char 'f'

249 val <- char 't' <|> char 'f'

255 return $ BoolAtom (val == 't')

250 return $ BoolAtom (val == 't')

251+

252+relationAtomP :: Parser Atom

253+relationAtomP = RelationAtom <$> relationP

254+

255+--relation constructor -- no choice but to propagate relation-construction errors as parse errors. Perhaps this could be improved in the future

256+relationP :: Parser Relation

257+relationP = do

258+ reserved "relation"

259+ attrs <- (try makeAttributesP <|> return A.emptyAttributes)

260+ if not (A.null attrs) then do

261+ case mkRelation attrs emptyTupleSet of

262+ Left err -> fail (show err)

263+ Right rel -> return rel

264+ else do

265+ tuples <- braces (sepBy tupleP comma)

266+ case mkRelation (tupleAttributes (head tuples)) (HS.fromList tuples) of

267+ Left err -> fail (show err)

268+ Right rel -> return rel

256

269

project-m36.cabal+1

@@ -18,6 +18,7 @@ Library

18 ProjectM36.TupleSet,

19 ProjectM36.Atom,

20 ProjectM36.AtomFunction,

21+ ProjectM36.Key,

21 ProjectM36.RelationalExpression,

22 ProjectM36.RelationalExpression,

22 ProjectM36.Relation.Show.HTML,

23 ProjectM36.Relation.Show.HTML,

23 ProjectM36.StaticOptimizer,

24 ProjectM36.StaticOptimizer,

test/TutorialD/Interpreter.hs+17−10

@@ -33,7 +33,7 @@ main = do

33 ("x:=relation{a int}", mkRelation simpleAAttributes emptyTupleSet),

34 ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),

35 ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),

36− ("x:=relation{tuple{a char(\"spam\"), b int(5)}}", mkRelation simpleCAttributes $ HS.singleton ((RelationTuple simpleCAttributes) (V.fromList [StringAtom "spam", IntAtom 5]))),

36+ ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ HS.singleton ((RelationTuple simpleCAttributes) (V.fromList [StringAtom "spam", IntAtom 5]))),

37 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),

38 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),

39 ("x:=true where true", Right relationTrue),

@@ -45,19 +45,22 @@ main = do

45 ("x:=true=true", Right relationTrue),

46 ("x:=true=false", Right relationFalse),

47 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),

48− ("x:=relation {b int, a char}; insert x relation{tuple{b int(5), a char(\"spam\")}}", mkRelation simpleCAttributes (HS.fromList [RelationTuple simpleCAttributes $ V.fromList [StringAtom "spam", IntAtom 5]])),

48+ ("x:=relation {b int, a char}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelation simpleCAttributes (HS.fromList [RelationTuple simpleCAttributes $ V.fromList [StringAtom "spam", IntAtom 5]])),

49+ -- test nested relation constructor

50+ ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ HS.singleton $ RelationTuple nestedRelationAttributes (V.fromList [IntAtom 5, RelationAtom (Relation simpleAAttributes (HS.singleton $ RelationTuple simpleAAttributes $ V.fromList [IntAtom 6]))])),

49− ("x:=relation{tuple{b int(5),a char(\"spam\")},tuple{b int(6),a char(\"sam\")}}; delete x where b=6", mkRelation simpleCAttributes $ HS.singleton $ RelationTuple simpleCAttributes (V.fromList [StringAtom "spam", IntAtom 5])),

51+ ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ HS.singleton $ RelationTuple simpleCAttributes (V.fromList [StringAtom "spam", IntAtom 5])),

50− ("x:=relation{tuple{a int(5)}} : {b:=@a}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 5])),

52+ ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 5])),

51− ("x:=relation{tuple{a int(5)}} : {b:=6}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 6])),

53+ ("x:=relation{tuple{a 5}} : {b:=6}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 6])),

52− ("x:=relation{tuple{a int(5)}} : {b:=add(@a,5)}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 10])),

54+ ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 10])),

53− ("x:=relation{tuple{a int(5)}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntAtomType StringAtomType)),

55+ ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntAtomType StringAtomType)),

54− ("x:=relation{tuple{a int(5)}} : {b:=add(add(@a,2),5)}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 12]))

56+ ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 12]))

55 ]

57 ]

56 simpleAAttributes = A.attributesFromList [Attribute "a" IntAtomType]

58 simpleAAttributes = A.attributesFromList [Attribute "a" IntAtomType]

57 simpleBAttributes = A.attributesFromList [Attribute "d" IntAtomType]

59 simpleBAttributes = A.attributesFromList [Attribute "d" IntAtomType]

58 simpleCAttributes = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" IntAtomType]

60 simpleCAttributes = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" IntAtomType]

59 simpleDAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" IntAtomType]

61 simpleDAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" IntAtomType]

60 simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]

62 simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]

63+ nestedRelationAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntAtomType])]

61 extendTestAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]

64 extendTestAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]

62 groupCountAttrs = A.attributesFromList [Attribute "z" IntAtomType]

65 groupCountAttrs = A.attributesFromList [Attribute "z" IntAtomType]

63 minMaxAttrs = A.attributesFromList [Attribute "S#" StringAtomType, Attribute "z" IntAtomType]

66 minMaxAttrs = A.attributesFromList [Attribute "S#" StringAtomType, Attribute "z" IntAtomType]

@@ -68,7 +71,7 @@ main = do

68 --atom function tests

71 --atom function tests

69 ("x:=((S : {STATUS2 := add(10,@STATUS)}) where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),

72 ("x:=((S : {STATUS2 := add(10,@STATUS)}) where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),

70 ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "SNAME" tuple == (Right $ StringAtom "Blake") then updateTuple (M.singleton "CITY" (StringAtom "Boston")) tuple else tuple) suppliersRel),

73 ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "SNAME" tuple == (Right $ StringAtom "Blake") then updateTuple (M.singleton "CITY" (StringAtom "Boston")) tuple else tuple) suppliersRel),

71− ("x:=relation{tuple{a int(5)}} : {b:=S}", mkRelation extendTestAttributes (HS.singleton $ mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel]))),

74+ ("x:=relation{tuple{a 5}} : {b:=S}", mkRelation extendTestAttributes (HS.singleton $ mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel]))),

72 --relatom function tests

75 --relatom function tests

73 ("x:=((S group ({CITY} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (HS.singleton $ mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1))),

76 ("x:=((S group ({CITY} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (HS.singleton $ mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1))),

74 ("x:=(SP group ({S#} as y)) ungroup y", Right supplierProductsRel),

77 ("x:=(SP group ({S#} as y)) ungroup y", Right supplierProductsRel),

@@ -82,7 +85,11 @@ main = do

82 ("x:=S where ^sum(@STATUS)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType),

85 ("x:=S where ^sum(@STATUS)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType),

83 ("x:=S where ^not(gte(@STATUS,20))", mkRelationFromList (attributes suppliersRel) [[StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"]]),

86 ("x:=S where ^not(gte(@STATUS,20))", mkRelationFromList (attributes suppliersRel) [[StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"]]),

84 --test "all but" attribute inversion syntax

87 --test "all but" attribute inversion syntax

85− ("x:=S{all but S#} = S{CITY,SNAME,STATUS}",Right $ relationTrue)

88+ ("x:=S{all but S#} = S{CITY,SNAME,STATUS}", Right $ relationTrue),

89+ --test key syntax

90+ ("x:=S; key testconstraint {S#,CITY} x; insert x relation{tuple{CITY \"London\", S# \"S1\", SNAME \"gonk\", STATUS 50}}", Left (InclusionDependencyCheckError "testconstraint")),

91+ ("y:=S; key testconstraint {S#} y; insert y relation{tuple{CITY \"London\", S# \"S6\", SNAME \"gonk\", STATUS 50}}; x:=y{S#} = S{S#} union relation{tuple{S# \"S6\"}}", Right $ relationTrue)

92+

86 ]

93 ]