b605de7 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

refactor RelationalError to be ADT

b605de7AgentM12 years ago

Relation.hs+9−11

compare with master

unifiedsplit

@@ -4,12 +4,12 @@ module Relation where

4import qualified Data.Map as M

5import qualified Data.Set as S

6import qualified Data.HashSet as HS

7−import qualified Control.Monad.Error as Err

9import RelationType

8import RelationType

10import RelationTuple

9import RelationTuple

11import RelationAttribute

10import RelationAttribute

12import RelationTupleSet

11import RelationTupleSet

12+import RelationalError

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

@@ -39,18 +39,16 @@ atomValueType (StringAtom _) = StringAtomType

39atomValueType (IntAtom _) = IntAtomType

40atomValueType (RelationAtom rel) = RelationAtomType (attributes rel)

42−instance Err.Error RelationalError where

43−

44mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation

42mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation

45mkRelation attrs tupleSet =

43mkRelation attrs tupleSet =

46 --check that all tuples have the same keys

44 --check that all tuples have the same keys

47 --check that all tuples have keys (1-N) where N is the attribute count

45 --check that all tuples have keys (1-N) where N is the attribute count

48 if differentTupleCounts

46 if differentTupleCounts

49− then Left $ RelationalError 1 "Tuple attribute count mismatch"

47+ then Left $ TupleAttributeCountMismatchError 0

50 else if not (fst (verifyRelationTupleSet tupleSet))

48 else if not (fst (verifyRelationTupleSet tupleSet))

51− then Left $ RelationalError 1 "Tuple values not of the same type for same keys"

49+ then Left $ TupleAttributeTypeMismatchError 0

52 else if attrCountMismatch

50 else if attrCountMismatch

53− then Left $ RelationalError 1 "Attribute count mismatch"

51+ then Left $ AttributeCountMismatchError 0

54 else

52 else

55 Right $ Relation attrs tupleSet

53 Right $ Relation attrs tupleSet

56 where

54 where

@@ -70,7 +68,7 @@ madeFalse = mkRelation M.empty emptyTupleSet

70union :: Relation -> Relation -> Either RelationalError Relation

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

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

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

72 if not (attrs1 == attrs2)

70 if not (attrs1 == attrs2)

73− then Left $ RelationalError 1 ("Attribute mismatch " ++ show attrs1 ++ show attrs2)

71+ then Left $ AttributeNameMismatchError (show attrs1 ++ show attrs2)

74 else

72 else

75 Right $ Relation attrs1 newtuples

73 Right $ Relation attrs1 newtuples

76 where

74 where

@@ -79,7 +77,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

79project :: S.Set AttributeName -> Relation -> Either RelationalError Relation

77project :: S.Set AttributeName -> Relation -> Either RelationalError Relation

80project projectionAttrNames rel@(Relation oldattrs rtuples) =

78project projectionAttrNames rel@(Relation oldattrs rtuples) =

81 if not $ attributeNamesContained projectionAttrNames (attributeNames rel)

79 if not $ attributeNamesContained projectionAttrNames (attributeNames rel)

82− then Left $ RelationalError 1 "Attributes mismatch"

80+ then Left $ AttributeNameMismatchError ""

83 else

81 else

84 relFold folder (Right $ Relation newAttrs HS.empty) rel

82 relFold folder (Right $ Relation newAttrs HS.empty) rel

85 where

83 where

@@ -98,9 +96,9 @@ tupleProject projectAttrs tupleIn@(RelationTuple tupleInMap) = RelationTuple $ M

98rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation

96rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation

99rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =

97rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =

100 if not attributeValid

98 if not attributeValid

101− then Left $ RelationalError 1 "No such attribute"

99+ then Left $ AttributeNameMismatchError ""

102 else if newAttributeInUse

100 else if newAttributeInUse

103− then Left $ RelationalError 1 ("Attribute \"" ++ newAttrName ++ "\" already in use.")

101+ then Left $ AttributeNameInUseError newAttrName

104 else

102 else

105 mkRelation newAttrs newTupSet

103 mkRelation newAttrs newTupSet

106 where

104 where

@@ -194,7 +192,7 @@ tupleUngroup relvalAttrName newAttrs tuple@(RelationTuple tupMap) = case (tupMap

194 where

192 where

195 unsafeRelValFromAtom :: Atom -> Relation

193 unsafeRelValFromAtom :: Atom -> Relation

196 unsafeRelValFromAtom (RelationAtom rel) = rel

194 unsafeRelValFromAtom (RelationAtom rel) = rel

197− _ -> Left $ RelationalError 1 "Attribute is not relation-valued."

195+ _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName

198

196

199--this is a hack needed because the relation attributes are untyped so we must dig into the relval to get the attribute names

197--this is a hack needed because the relation attributes are untyped so we must dig into the relval to get the attribute names

200attributesForRelval :: AttributeName -> Relation -> Attributes

198attributesForRelval :: AttributeName -> Relation -> Attributes

RelationExpr.hs+2−1

@@ -3,6 +3,7 @@ module RelationExpr where

3import Relation

4import RelationTuple

5import RelationType

6+import RelationalError

6import qualified Data.Set as S

7import qualified Data.Set as S

7import qualified Data.Map as M

8import qualified Data.Map as M

8import qualified Data.HashSet as HS

9import qualified Data.HashSet as HS

@@ -49,7 +50,7 @@ eval (RelationVariable name) = do

49 relvarTable <- get

50 relvarTable <- get

50 return $ case M.lookup name relvarTable of

51 return $ case M.lookup name relvarTable of

51 Just res -> Right res

52 Just res -> Right res

52− Nothing -> Left (RelationalError 1 (name ++ " has not been defined."))

53+ Nothing -> Left $ RelvarNotDefinedError name

54eval (Project attrNameSet expr) = do

55eval (Project attrNameSet expr) = do

55 rel <- eval expr

56 rel <- eval expr

RelationTest.hs+6−5

@@ -1,6 +1,7 @@

1import Test.HUnit

2import RelationType

3import Relation

4+import RelationalError

4import RelationTuple

5import RelationTuple

5import RelationTupleSet

6import RelationTupleSet

6import qualified Data.Set as S

7import qualified Data.Set as S

@@ -30,7 +31,7 @@ validateRelation rel = do

30validateAttrNamesMatchTupleAttrNames :: Relation -> Either RelationalError Relation

31validateAttrNamesMatchTupleAttrNames :: Relation -> Either RelationalError Relation

31validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupMapSet)

32validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupMapSet)

32 | HS.null invalidSet = Right rel

33 | HS.null invalidSet = Right rel

33− | otherwise = Left (RelationalError 1 "Tuple attributes do not match relation attributes")

34+ | otherwise = Left $ AttributeNameMismatchError ""

34 where

35 where

35 nameCheck (RelationTuple tupMap) = attributeNames rel == M.keysSet tupMap

36 nameCheck (RelationTuple tupMap) = attributeNames rel == M.keysSet tupMap

36 relAttrNames = attributeNames rel

37 relAttrNames = attributeNames rel

@@ -40,7 +41,7 @@ validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupMapSet)

40validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation

41validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation

41validateAttrTypesMatchTupleAttrTypes rel@(Relation _ tupMapSet)

42validateAttrTypesMatchTupleAttrTypes rel@(Relation _ tupMapSet)

42 | HS.null invalidSet = Right rel

43 | HS.null invalidSet = Right rel

43− | otherwise = Left (RelationalError 1 "Tuple types do not match relation attribute types")

44+ | otherwise = Left (TupleAttributeTypeMismatchError 0)

44 where

45 where

45 tupleTypeCheck (RelationTuple tupMap) = M.null $ M.filterWithKey attrTypeCheck tupMap

46 tupleTypeCheck (RelationTuple tupMap) = M.null $ M.filterWithKey attrTypeCheck tupMap

46 attrTypeCheck attrName atomValue = case attributeTypeForName attrName rel of

47 attrTypeCheck attrName atomValue = case attributeTypeForName attrName rel of

@@ -59,15 +60,15 @@ simpleRel = case mkRelation attrs tupleSet of

60--rename tests

61--rename tests

61testRename1 :: Test

62testRename1 :: Test

62−testRename1 = TestCase $ assertEqual "attribute invalid" (rename "a" "b" relationTrue) (Left $ RelationalError 1 "No such attribute")

63+testRename1 = TestCase $ assertEqual "attribute invalid" (rename "a" "b" relationTrue) (Left $ AttributeNameMismatchError "")

64testRename2 :: Test

65testRename2 :: Test

65−testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRel) (Left $ RelationalError 1 "Attribute \"a\" already in use.")

66+testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRel) (Left $ AttributeNameInUseError "a")

67--mkRelation tests

68--mkRelation tests

68--test tupleset key mismatch failure

69--test tupleset key mismatch failure

69testMkRelation1 :: Test

70testMkRelation1 :: Test

70−testMkRelation1 = TestCase $ assertEqual "key mismatch" (mkRelation testAttrs testTupSet) (Left $ RelationalError 1 "Tuple values not of the same type for same keys")

71+testMkRelation1 = TestCase $ assertEqual "key mismatch" (mkRelation testAttrs testTupSet) (Left $ AttributeCountMismatchError 0)

71 where

72 where

72 testAttrs = M.singleton "a" (Attribute "a" StringAtomType)

73 testAttrs = M.singleton "a" (Attribute "a" StringAtomType)

73 testTupSet = HS.fromList [(RelationTuple (M.singleton "a" $ StringAtom "v")),

74 testTupSet = HS.fromList [(RelationTuple (M.singleton "a" $ StringAtom "v")),

RelationType.hs+1−1

@@ -27,4 +27,4 @@ data Relation = Relation Attributes RelationTupleSet deriving (Show, Eq)

27data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show)

28data RelationSizeInfinite = RelationSizeInfinite

30−data RelationalError = RelationalError Int String deriving (Show,Eq)

30+

RelationalError.hsnew file+17

@@ -0,0 +1,17 @@

1+module RelationalError where

2+import qualified Control.Monad.Error as Err

3+import RelationType

5+data RelationalError = NoSuchAttributeNameError String

6+ | TupleAttributeCountMismatchError Int

7+ | TupleAttributeTypeMismatchError Int

8+ | AttributeCountMismatchError Int

9+ | AttributeNameMismatchError String

10+ | AttributeNameInUseError AttributeName

11+ | AttributeIsNotRelationValuedError AttributeName

12+ | RelvarNotDefinedError String

13+ | ParseError String

14+ deriving (Show,Eq)

15+

16+instance Err.Error RelationalError where

17+

TutorialDInterpreter.hs+7−4

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

1module TutorialDInterpreter where

2import RelationType

3+import RelationalError

3import RelationExpr

4import RelationExpr

4import RelationTerm

5import RelationTerm

5import Text.Parsec

6import Text.Parsec

@@ -129,10 +130,10 @@ multipleRelExpr = do

129 exprs <- sepBy1 relExpr semi

130 exprs <- sepBy1 relExpr semi

130 return $ MultipleExpr exprs

131 return $ MultipleExpr exprs

131

132

132−parseString :: String -> RelationalExpr

133+parseString :: String -> Either RelationalError RelationalExpr

133parseString str = case parse multipleRelExpr "" str of

134parseString str = case parse multipleRelExpr "" str of

134− Left err -> error $ show err

135+ Left err -> Left $ ParseError (show err)

135− Right r -> r

136+ Right r -> Right r

136

137

137example1 = "relA {a,b, c}"

138example1 = "relA {a,b, c}"

138example2 = "relA join relB"

139example2 = "relA join relB"

@@ -145,7 +146,9 @@ example8 = "relA := true; relB := false"

145example9 = "relA := relation { SNO CHAR }"

146example9 = "relA := relation { SNO CHAR }"

146

147

147interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVarContext)

148interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVarContext)

148−interpret context tutdstring = runState (eval (parseString tutdstring)) context

149+interpret context tutdstring = case parseString tutdstring of

150+ Left err -> (Left err, context)

151+ Right parsed -> runState (eval parsed) context

149

152

150reprLoop :: RelVarContext -> IO ()

153reprLoop :: RelVarContext -> IO ()

151reprLoop context = do

154reprLoop context = do