git.iko.soy/project-m36
on master help sign in
refactor RelationalError to be ADT
commitb605de75007714fa4a5df603818752f556572483 authorAgentM <agentm@themactionfaction.com> dateWed 12 Nov 2014, 18:45 (12 years ago) parent444ab48
6 files changed+42−22
compare with master
unifiedsplit
Relation.hs+9−11 RelationExpr.hs+2−1 RelationTest.hs+6−5 RelationType.hs+1−1 RelationalError.hs+17 TutorialDInterpreter.hs+7−4
Relation.hs+9−11
@@ -4,12 +4,12 @@ module Relation where
44import qualified Data.Map as M
55import qualified Data.Set as S
66import qualified Data.HashSet as HS
7−import qualified Control.Monad.Error as Err
87
98import RelationType
109import RelationTuple
1110import RelationAttribute
1211import RelationTupleSet
12+import RelationalError
1313
1414testTuple1 = mkRelationTuple (S.fromList ["hair"]) (M.fromList [("hair", StringAtom "brown")])
1515
@@ -39,18 +39,16 @@ atomValueType (StringAtom _) = StringAtomType
3939atomValueType (IntAtom _) = IntAtomType
4040atomValueType (RelationAtom rel) = RelationAtomType (attributes rel)
4141
42−instance Err.Error RelationalError where
43−
4442mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
4543mkRelation attrs tupleSet =
4644 --check that all tuples have the same keys
4745 --check that all tuples have keys (1-N) where N is the attribute count
4846 if differentTupleCounts
49− then Left $ RelationalError 1 "Tuple attribute count mismatch"
47+ then Left $ TupleAttributeCountMismatchError 0
5048 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
5250 else if attrCountMismatch
53− then Left $ RelationalError 1 "Attribute count mismatch"
51+ then Left $ AttributeCountMismatchError 0
5452 else
5553 Right $ Relation attrs tupleSet
5654 where
@@ -70,7 +68,7 @@ madeFalse = mkRelation M.empty emptyTupleSet
7068union :: Relation -> Relation -> Either RelationalError Relation
7169union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
7270 if not (attrs1 == attrs2)
73− then Left $ RelationalError 1 ("Attribute mismatch " ++ show attrs1 ++ show attrs2)
71+ then Left $ AttributeNameMismatchError (show attrs1 ++ show attrs2)
7472 else
7573 Right $ Relation attrs1 newtuples
7674 where
@@ -79,7 +77,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
7977project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
8078project projectionAttrNames rel@(Relation oldattrs rtuples) =
8179 if not $ attributeNamesContained projectionAttrNames (attributeNames rel)
82− then Left $ RelationalError 1 "Attributes mismatch"
80+ then Left $ AttributeNameMismatchError ""
8381 else
8482 relFold folder (Right $ Relation newAttrs HS.empty) rel
8583 where
@@ -98,9 +96,9 @@ tupleProject projectAttrs tupleIn@(RelationTuple tupleInMap) = RelationTuple $ M
9896rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
9997rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
10098 if not attributeValid
101− then Left $ RelationalError 1 "No such attribute"
99+ then Left $ AttributeNameMismatchError ""
102100 else if newAttributeInUse
103− then Left $ RelationalError 1 ("Attribute \"" ++ newAttrName ++ "\" already in use.")
101+ then Left $ AttributeNameInUseError newAttrName
104102 else
105103 mkRelation newAttrs newTupSet
106104 where
@@ -194,7 +192,7 @@ tupleUngroup relvalAttrName newAttrs tuple@(RelationTuple tupMap) = case (tupMap
194192 where
195193 unsafeRelValFromAtom :: Atom -> Relation
196194 unsafeRelValFromAtom (RelationAtom rel) = rel
197− _ -> Left $ RelationalError 1 "Attribute is not relation-valued."
195+ _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName
198196
199197--this is a hack needed because the relation attributes are untyped so we must dig into the relval to get the attribute names
200198attributesForRelval :: AttributeName -> Relation -> Attributes
RelationExpr.hs+2−1
@@ -3,6 +3,7 @@ module RelationExpr where
33import Relation
44import RelationTuple
55import RelationType
6+import RelationalError
67import qualified Data.Set as S
78import qualified Data.Map as M
89import qualified Data.HashSet as HS
@@ -49,7 +50,7 @@ eval (RelationVariable name) = do
4950 relvarTable <- get
5051 return $ case M.lookup name relvarTable of
5152 Just res -> Right res
52− Nothing -> Left (RelationalError 1 (name ++ " has not been defined."))
53+ Nothing -> Left $ RelvarNotDefinedError name
5354
5455eval (Project attrNameSet expr) = do
5556 rel <- eval expr
RelationTest.hs+6−5
@@ -1,6 +1,7 @@
11import Test.HUnit
22import RelationType
33import Relation
4+import RelationalError
45import RelationTuple
56import RelationTupleSet
67import qualified Data.Set as S
@@ -30,7 +31,7 @@ validateRelation rel = do
3031validateAttrNamesMatchTupleAttrNames :: Relation -> Either RelationalError Relation
3132validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupMapSet)
3233 | HS.null invalidSet = Right rel
33− | otherwise = Left (RelationalError 1 "Tuple attributes do not match relation attributes")
34+ | otherwise = Left $ AttributeNameMismatchError ""
3435 where
3536 nameCheck (RelationTuple tupMap) = attributeNames rel == M.keysSet tupMap
3637 relAttrNames = attributeNames rel
@@ -40,7 +41,7 @@ validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupMapSet)
4041validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation
4142validateAttrTypesMatchTupleAttrTypes rel@(Relation _ tupMapSet)
4243 | HS.null invalidSet = Right rel
43− | otherwise = Left (RelationalError 1 "Tuple types do not match relation attribute types")
44+ | otherwise = Left (TupleAttributeTypeMismatchError 0)
4445 where
4546 tupleTypeCheck (RelationTuple tupMap) = M.null $ M.filterWithKey attrTypeCheck tupMap
4647 attrTypeCheck attrName atomValue = case attributeTypeForName attrName rel of
@@ -59,15 +60,15 @@ simpleRel = case mkRelation attrs tupleSet of
5960
6061--rename tests
6162testRename1 :: 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 "")
6364
6465testRename2 :: 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")
6667
6768--mkRelation tests
6869--test tupleset key mismatch failure
6970testMkRelation1 :: 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)
7172 where
7273 testAttrs = M.singleton "a" (Attribute "a" StringAtomType)
7374 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)
2727data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show)
2828data RelationSizeInfinite = RelationSizeInfinite
2929
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
4+
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 @@
11module TutorialDInterpreter where
22import RelationType
3+import RelationalError
34import RelationExpr
45import RelationTerm
56import Text.Parsec
@@ -129,10 +130,10 @@ multipleRelExpr = do
129130 exprs <- sepBy1 relExpr semi
130131 return $ MultipleExpr exprs
131132
132−parseString :: String -> RelationalExpr
133+parseString :: String -> Either RelationalError RelationalExpr
133134parseString str = case parse multipleRelExpr "" str of
134− Left err -> error $ show err
135− Right r -> r
135+ Left err -> Left $ ParseError (show err)
136+ Right r -> Right r
136137
137138example1 = "relA {a,b, c}"
138139example2 = "relA join relB"
@@ -145,7 +146,9 @@ example8 = "relA := true; relB := false"
145146example9 = "relA := relation { SNO CHAR }"
146147
147148interpret :: 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
149152
150153reprLoop :: RelVarContext -> IO ()
151154reprLoop context = do