6cbd8a3 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

implement basic restriction clauses and evaluation

6cbd8a3AgentM12 years ago

READMEdeleted−4

compare with master

unifiedsplit

@@ -1,4 +0,0 @@

1−# Project:M36

2−## Relational Algebra Engine

3−

4−Project:M36 implements a relational algebra engine as (mostly) specified by Chris Date.

Relation.hs+18−1

@@ -1,5 +1,5 @@

1-- this is an implementation of the Relation typeclass which creates a GADT DSL

2−{-# LANGUAGE GADTs,ExistentialQuantification #-}

2+{-# LANGUAGE GADTs,ExistentialQuantification,NoImplicitPrelude #-}

3module Relation where

4import qualified Data.Map as M

5import qualified Data.Set as S

@@ -10,6 +10,7 @@ import RelationTuple

10import RelationAttribute

11import RelationTupleSet

12import RelationalError

13+import Prelude hiding (join)

14testTuple1 = mkRelationTuple (S.fromList ["hair"]) (M.fromList [("hair", StringAtom "brown")])

15testTuple1 = mkRelationTuple (S.fromList ["hair"]) (M.fromList [("hair", StringAtom "brown")])

@@ -65,6 +66,19 @@ relationFalse = Relation M.empty emptyTupleSet

65madeTrue = mkRelation M.empty (HS.fromList [])

66madeTrue = mkRelation M.empty (HS.fromList [])

66madeFalse = mkRelation M.empty emptyTupleSet

67madeFalse = mkRelation M.empty emptyTupleSet

69+--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

70+singletonValueFromRelation :: Relation -> Either RelationalError Atom

71+singletonValueFromRelation rel@(Relation _ tupSet) = if cardinality rel /= Countable 1 then

72+ Left (PredicateExpressionError "Relational expression must have cardinality 1")

73+ else if arity rel /= 1 then

74+ Left (PredicateExpressionError "Relation expression must have arity 1")

75+ else

76+ Right value

77+ where

78+ value = snd $ head $ M.toList tupMap

79+ tupMap = tup2Map $ head (HS.toList tupSet)

80+ tup2Map (RelationTuple tupMap) = tupMap

81+

68union :: Relation -> Relation -> Either RelationalError Relation

82union :: Relation -> Relation -> Either RelationalError Relation

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

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

70 if not (attrs1 == attrs2)

84 if not (attrs1 == attrs2)

@@ -297,3 +311,6 @@ relvarSP = mkRelation attributes tupleSet

297

311

298sp = case relvarSP of { Right r -> r }

312sp = case relvarSP of { Right r -> r }

299

313

314+

315+

316+

RelationExpr.hs+42

@@ -63,6 +63,15 @@ evalRelationalExpr (Ungroup attrName relExpr) = do

63 case evald of

64 Right rel -> return $ ungroup attrName rel

65 Left err -> return $ Left err

66+

67+evalRelationalExpr (Restrict predicateExpr relExpr) = do

68+ evald <- evalRelationalExpr relExpr

69+ context <- get

70+ case evald of

71+ Left err -> return $ Left err

72+ Right rel -> case predicateRestrictionFilter context predicateExpr of

73+ Left err -> return $ Left err

74+ Right filterfunc -> return $ restrict filterfunc rel

67emptyDatabaseContext :: DatabaseContext

76emptyDatabaseContext :: DatabaseContext

68emptyDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

77emptyDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

@@ -233,6 +242,39 @@ checkConstraint (InclusionDependency name subDep superDep) = do

233 return $ Nothing

242 return $ Nothing

234-}

243-}

235

244

245+-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing

246+-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation

247+typeForRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)

248+typeForRelationalExpr expr = do

249+ state <- get

250+ --replace the relationVariables context element with a cloned set of relation devoid of tuples

251+ put $ DatabaseContext (inclusionDependencies state) $ M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables state)

252+ evalRelationalExpr expr

253+

254+{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

255+predicateRestrictionFilter :: DatabaseContext -> RestrictionPredicateExpr -> Either RelationalError (RelationTuple -> Bool)

256+predicateRestrictionFilter context (AndPredicate expr1 expr2) = do

257+ expr1v <- predicateRestrictionFilter context expr1

258+ expr2v <- predicateRestrictionFilter context expr2

259+ return $ \x -> expr1v x && expr2v x

260+

261+predicateRestrictionFilter context (OrPredicate expr1 expr2) = do

262+ expr1v <- predicateRestrictionFilter context expr1

263+ expr2v <- predicateRestrictionFilter context expr2

264+ return $ \x -> expr1v x || expr2v x

265+

266+predicateRestrictionFilter context (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of

267+ (Left err, _) -> Left err

268+ (Right rel, _) -> if rel == relationTrue then

269+ Right $ \x -> True

270+ else if rel == relationFalse then

271+ Right $ \x -> False

272+ else

273+ Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"

274+

275+predicateRestrictionFilter context (AttributeEqualityPredicate attrName atom) = Right $ \(RelationTuple tupMap) -> tupValue tupMap == atom

276+ where

277+ tupValue tupMap = tupMap M.! attrName

236

278

237

279

238

280

RelationTerm.hs+1−1

@@ -42,7 +42,7 @@ cellLocations :: Table -> ([Int],[Int]) --column size, row size

42cellLocations tab@(header, body) = (maxWidths, maxHeights)

43 where

44 cellSizeMatrix = cellSizes tab

45− maxWidths = foldl mergeMax (baseSize (length cellSizeMatrix)) (map fst cellSizeMatrix)

45+ maxWidths = foldl mergeMax (baseSize (length header)) (map fst cellSizeMatrix)

46 baseSize num = take num (repeat 0)

47 rowHeights = map snd cellSizeMatrix

48 maxHeights = map (L.maximumBy compare) rowHeights

RelationType.hs+9−2

@@ -13,7 +13,7 @@ data Atom = StringAtom String |

13data AtomType = StringAtomType |

14 IntAtomType |

15 RelationAtomType Attributes deriving (Eq, Show)

16−

16+

17type AttributeName = String

18type AtomName = String

@@ -44,7 +44,7 @@ data RelationalExpr where

44 Rename :: AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr

45 Group :: S.Set AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr

46 Ungroup :: AttributeName -> RelationalExpr -> RelationalExpr

47− --Restrict :: RExpr.RestrictionExpr -> RelationalExpr -> RelationalExpr

47+ Restrict :: RestrictionPredicateExpr -> RelationalExpr -> RelationalExpr

49{- maybe break this into multiple steps:

501. check relational types for match (attribute counts) (typechecking step

@@ -78,3 +78,10 @@ data DatabaseExpr where

78 deriving (Show)

80type DatabaseState a = State DatabaseContext a

81+

82+data RestrictionPredicateExpr where

83+ AndPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr -> RestrictionPredicateExpr

84+ OrPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr -> RestrictionPredicateExpr

85+ RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)

86+ AttributeEqualityPredicate :: AttributeName -> Atom -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple

87+ deriving (Show)

RelationalError.hs+1

@@ -13,6 +13,7 @@ data RelationalError = NoSuchAttributeNameError String

13 | RelVarAssignmentTypeMismatchError

14 | InclusionDependencyCheckError String

15 | ParseError String

16+ | PredicateExpressionError String

16 deriving (Show,Eq)

17 deriving (Show,Eq)

TutorialDInterpreter.hs+45−15

@@ -14,7 +14,7 @@ import qualified Data.Set as S

14import qualified Data.HashSet as HS

15import qualified Data.Map as M

16import qualified Data.List as L

17−import Control.Applicative (liftA)

17+import Control.Applicative (liftA, (<*), (*>))

18import Control.Monad.State

19import System.Console.Readline

@@ -108,6 +108,11 @@ renameP = do

108 (oldAttr, newAttr) <- braces renameClause

109 return $ Rename oldAttr newAttr

110

111+whereClauseP = do

112+ reservedOp "where"

113+ boolExpr <- restrictionPredicateP

114+ return $ Restrict boolExpr

115+

111groupClause = do

116groupClause = do

112 attrs <- braces attributeList

117 attrs <- braces attributeList

113 reservedOp "as"

118 reservedOp "as"

@@ -130,6 +135,7 @@ ungroupP = do

130relOperators = [

135relOperators = [

131 [Postfix projectOp],

136 [Postfix projectOp],

132 [Postfix renameP],

137 [Postfix renameP],

138+ [Postfix whereClauseP],

133 [Postfix groupP],

139 [Postfix groupP],

134 [Postfix ungroupP],

140 [Postfix ungroupP],

135 [Infix (reservedOp "join" >> return Join) AssocLeft],

141 [Infix (reservedOp "join" >> return Join) AssocLeft],

@@ -182,14 +188,6 @@ updateP = do

182 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)

188 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)

183 return $ Update relVarName attributeAssignments

189 return $ Update relVarName attributeAssignments

184

190

185−{-

186−restrictionPredicateP :: Parser RestrictionPredicateExpr

187−restrictionPredicateP = do

188− sepBy1 subexpr (

189− where

190− subexpr = try attributeEqP <|>

191−-}

192−

193constraintP :: Parser DatabaseExpr

191constraintP :: Parser DatabaseExpr

194constraintP = do

192constraintP = do

195 reservedOp "constraint"

193 reservedOp "constraint"

@@ -213,15 +211,15 @@ parseString str = case parse multipleDatabaseExpr "" str of

213

211

214data TutorialDOperator where

212data TutorialDOperator where

215 ShowRelation :: RelationalExpr -> TutorialDOperator

213 ShowRelation :: RelationalExpr -> TutorialDOperator

216− ShowRelationVariableType :: String -> TutorialDOperator

214+ ShowRelationType :: RelationalExpr -> TutorialDOperator

217 ShowConstraint :: String -> TutorialDOperator

215 ShowConstraint :: String -> TutorialDOperator

218 deriving (Show)

216 deriving (Show)

219

217

220typeP :: Parser TutorialDOperator

218typeP :: Parser TutorialDOperator

221typeP = do

219typeP = do

222 reservedOp ":t"

220 reservedOp ":t"

223− relVarName <- identifier

221+ expr <- relExpr

224− return $ ShowRelationVariableType relVarName

222+ return $ ShowRelationType expr

225

223

226showRelP :: Parser TutorialDOperator

224showRelP :: Parser TutorialDOperator

227showRelP = do

225showRelP = do

@@ -250,9 +248,9 @@ showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribu

250 values m = map snd (M.toAscList m)

248 values m = map snd (M.toAscList m)

251

249

252evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> String

250evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> String

253−evalTutorialDOp context (ShowRelationVariableType relVarName) = case M.lookup relVarName (relationVariables context) of

251+evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of

254− Just rel -> showRelationAttributes rel

252+ (Right rel, _) -> showRelationAttributes rel

255− Nothing -> relVarName ++ " not defined"

253+ (Left err, _) -> show err

256

254

257evalTutorialDOp context (ShowRelation expr) = do

255evalTutorialDOp context (ShowRelation expr) = do

258 case runState (evalRelationalExpr expr) context of

256 case runState (evalRelationalExpr expr) context of

@@ -309,3 +307,35 @@ reprLoop context = do

309 putStrLn $ show err

307 putStrLn $ show err

310 reprLoop context

308 reprLoop context

311

309

310+restrictionPredicateP :: Parser RestrictionPredicateExpr

311+restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm

312+ where

313+ predicateOperators = [

314+ [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],

315+ [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]

316+ ]

317+ predicateTerm = parens restrictionPredicateP

318+ <|> try restrictionAttributeEqualityP

319+ <|> relationalBooleanExpr

320+

321+relationalBooleanExpr :: Parser RestrictionPredicateExpr

322+relationalBooleanExpr = do

323+ relexpr <- relExpr

324+ return $ RelationalExprPredicate relexpr

325+

326+restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr

327+restrictionAttributeEqualityP = do

328+ attributeName <- identifier

329+ reservedOp "="

330+ atom <- stringAtomP <|> intAtomP

331+ return $ AttributeEqualityPredicate attributeName atom

332+

333+quotedChar = noneOf "\""

334+ <|> try (string "\"\"" >> return '"')

335+

336+stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")

337+

338+intAtomP = do

339+ intstr <- many digit

340+ return $ IntAtom (read intstr)

341+

TutorialDInterpreterTest.hs+13−3

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

12 counts <- runTestTT (TestList tests)

13 if errors counts + failures counts > 0 then exitFailure else exitSuccess

14 where

15− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext tutd expected) simpleRelTests

15+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext tutd expected) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples tutd expected) dateExampleRelTests

16 simpleRelTests = [("x:=true", Right relationTrue),

17 ("x:=false", Right relationFalse),

18 ("x:=true union false", Right relationTrue),

@@ -20,11 +20,21 @@ main = do

20 ("x:=relation{a int}", mkRelation simpleAAttributes HS.empty),

21 ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes HS.empty),

22 ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes HS.empty),

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

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

24+ ("x:=true where true", Right relationTrue),

25+ ("x:=true where false", Right relationFalse),

26+ ("x:=true where true or false", Right relationTrue),

27+ ("x:=true where false or false", Right relationFalse),

28+ ("x:=true where true and false", Right relationFalse),

29+ ("x:=true where true and true", Right relationTrue)

24− ]

30+ ]

25 simpleAAttributes = M.fromList [("a", Attribute "a" IntAtomType)]

31 simpleAAttributes = M.fromList [("a", Attribute "a" IntAtomType)]

26 simpleBAttributes = M.fromList [("d", Attribute "d" IntAtomType)]

32 simpleBAttributes = M.fromList [("d", Attribute "d" IntAtomType)]

27 simpleProjectionAttributes = M.fromList [("c", Attribute "c" IntAtomType)]

33 simpleProjectionAttributes = M.fromList [("c", Attribute "c" IntAtomType)]

34+ dateExampleRelTests = [("x:=S where true", Right s),

35+ ("x:=S where CITY = \"London\"", restrict (\(RelationTuple tupMap) -> tupMap M.! "CITY" == StringAtom "London") s),

36+ ("x:=S where false", Right $ Relation (attributes s) HS.empty)]

37+ --("x:=S where SNO in S{SNO}", Right s)]

30testSimple1 = TestCase $ assertTutdEqual basicDatabaseContext "true" (Right relationTrue)

40testSimple1 = TestCase $ assertTutdEqual basicDatabaseContext "true" (Right relationTrue)