5582a55 · project-m36 · git.iko.soy

git.iko.soy/project-m36

-further polish tuple expression parsing

-add @attributename for context-free parsing in tuple expressions -add tuple expression parsing to where clauses (restriction) -more tests- all pass

commit5582a5536189532b0c18acd1e3d0fb2d7e3f13ca authorAgentM <agentm@themactionfaction.com> dateWed 20 May 2015, 22:47 (11 years ago) parentffd382f

7 files changed+78−37

compare with master

unifiedsplit

ProjectM36/Base.hs+1−1 ProjectM36/Error.hs+1 ProjectM36/Relation/Show/Term.hs+4−1 ProjectM36/RelationalExpression.hs+44−22 TutorialD/Interpreter.hs+12−10 test/Relation/Basic.hs+6−1 test/TutorialD/Interpreter.hs+10−2

ProjectM36/Base.hs+1−1

@@ -154,7 +154,7 @@ data RestrictionPredicateExpr where

154154 OrPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr -> RestrictionPredicateExpr

155155 NotPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr

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

157− AttributeEqualityPredicate :: AttributeName -> Atom -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple

157+ AttributeEqualityPredicate :: AttributeName -> AtomExpr -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple

158158 deriving (Show, Eq)

159159

160160-- child + parent links

ProjectM36/Error.hs+1

@@ -28,6 +28,7 @@ data RelationalError = NoSuchAttributeNameError AttributeName

2828 | NoSuchTupleExprFunctionError AtomFunctionName

2929 | AtomTypeMismatchError AtomType AtomType

3030 | AtomTypeCountError [AtomType] [AtomType]

31+ | AtomFunctionTypeError AtomFunctionName Int AtomType AtomType --arg number

3132 deriving (Show,Eq,Generic)

3233

3334

ProjectM36/Relation/Show/Term.hs+4−1

@@ -109,7 +109,10 @@ renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType

109109renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (\x -> repeatString x boxH) columnLocations)) `T.append` end

110110

111111leftPaddedString :: Int -> Int -> StringType -> StringType

112−leftPaddedString lineNum size str = paddedLines !! lineNum

112+leftPaddedString lineNum size str = if lineNum > length paddedLines -1 then

113+ repeatString size " "

114+ else

115+ paddedLines !! lineNum

113116 where

114117 paddedLines = map (\line -> line `T.append` repeatString (size - T.length line) " ") (breakLines str)

115118

ProjectM36/RelationalExpression.hs+44−22

@@ -12,6 +12,7 @@ import qualified Data.HashSet as HS

1212import Control.Monad.State hiding (join)

1313import Data.Maybe

1414import Data.Either

15+import Debug.Trace

1516

1617--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values

1718evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)

@@ -91,11 +92,11 @@ evalRelationalExpr (Equals relExprA relExprB) = do

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

9293evalRelationalExpr (Extend tupleExpression relExpr) = do

9394 evald <- evalRelationalExpr relExpr

94− funcs <- liftM atomFunctions get

95+ context <- get

9596 case evald of

9697 Left err -> return $ Left err

9798 Right rel -> do

98− case tupleExpressionProcessor rel tupleExpression funcs of

99+ case tupleExpressionProcessor rel tupleExpression context of

99100 Left err -> return $ Left err

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

101102

@@ -147,7 +148,7 @@ supplierProductsRel = case mkRelationFromList attrs matrix of

147148 where

148149 attrs = A.attributesFromList [Attribute "S#" StringAtomType,

149150 Attribute "P#" StringAtomType,

150− Attribute "QTY" StringAtomType]

151+ Attribute "QTY" IntAtomType]

151152 matrix = [

152153 [StringAtom "S1", StringAtom "P1", IntAtom 300],

153154 [StringAtom "S1", StringAtom "P2", IntAtom 200],

@@ -165,13 +166,13 @@ supplierProductsRel = case mkRelationFromList attrs matrix of

165166

166167productsRel :: Relation

167168productsRel = case mkRelationFromList attrs matrix of

168− Left _ -> undefined

169+ Left err -> traceShow (show err) undefined

169170 Right rel -> rel

170171 where

171172 attrs = A.attributesFromList [Attribute "P#" StringAtomType,

172173 Attribute "PNAME" StringAtomType,

173174 Attribute "COLOR" StringAtomType,

174− Attribute "WEIGHT" StringAtomType,

175+ Attribute "WEIGHT" IntAtomType,

175176 Attribute "CITY" StringAtomType]

176177 matrix = [

177178 [StringAtom "P1", StringAtom "Nut", StringAtom "Red", IntAtom 12, StringAtom "London"],

@@ -352,9 +353,13 @@ predicateRestrictionFilter context (RelationalExprPredicate relExpr) = case runS

352353 else

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

354355

355−predicateRestrictionFilter _ (AttributeEqualityPredicate attrName atom) = Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of

356+predicateRestrictionFilter context (AttributeEqualityPredicate attrName atomexpr) = Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of

356357 Left _ -> False

357− Right atom2 -> atom2 == atom

358+ Right atomIn ->

359+ case evalAtomExpr tupleIn context atomexpr of

360+ Left _ -> False

361+ Right atomCmp -> atomCmp == atomIn

362+

358363

359364tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation

360365tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then

@@ -362,15 +367,15 @@ tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName

362367 else

363368 Right rel

364369

365−tupleExpressionProcessor :: Relation -> TupleExpr -> AtomFunctions -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)

370+tupleExpressionProcessor :: Relation -> TupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)

366371tupleExpressionProcessor relIn

367− (AttributeTupleExpr newAttrName atomExpr) functions = do

372+ (AttributeTupleExpr newAttrName atomExpr) context = do

368373 _ <- tupleExprCheckNewAttrName newAttrName relIn

369− atomExprType <- typeFromAtomExpr (attributes relIn) functions atomExpr

370− _ <- verifyAtomExprTypes relIn functions atomExpr atomExprType

374+ atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr

375+ _ <- verifyAtomExprTypes relIn context atomExpr atomExprType

371376 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType]

372377 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

373− return $ (newAndOldAttrs, \tup -> case evalAtomExpr tup functions atomExpr of

378+ return $ (newAndOldAttrs, \tup -> case evalAtomExpr tup context atomExpr of

374379 Left _ -> undefined -- ?!

375380 Right atom -> tupleAtomExtend newAttrName atom tup)

376381

@@ -394,26 +399,40 @@ atomFunctionForName funcName funcSet = if HS.null foundFunc then

394399 where

395400 foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet

396401

397−typeFromAtomExpr :: Attributes -> AtomFunctions -> AtomExpr -> Either RelationalError AtomType

402+typeFromAtomExpr :: Attributes -> DatabaseContext -> AtomExpr -> Either RelationalError AtomType

398403typeFromAtomExpr attrs _ (AttributeAtomExpr attrName) = A.atomTypeForAttributeName attrName attrs

399404typeFromAtomExpr _ _ (NakedAtomExpr atom) = Right (atomTypeForAtom atom)

400−typeFromAtomExpr _ funcs (FunctionAtomExpr funcName _) = do

405+typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do

406+ let funcs = atomFunctions context

401407 func <- atomFunctionForName funcName funcs

402408 return $ last (atomFuncType func)

409+typeFromAtomExpr _ context (RelationAtomExpr relExpr) = do

410+ relType <- evalState (typeForRelationalExpr relExpr) context

411+ return $ RelationAtomType (attributes relType)

412+

403413

404−verifyAtomExprTypes :: Relation -> AtomFunctions -> AtomExpr -> AtomType -> Either RelationalError AtomType

414+verifyAtomExprTypes :: Relation -> DatabaseContext -> AtomExpr -> AtomType -> Either RelationalError AtomType

405415verifyAtomExprTypes relIn _ (AttributeAtomExpr attrName) expectedType = do

406416 attrType <- A.atomTypeForAttributeName attrName (attributes relIn)

407417 atomTypeVerify expectedType attrType

408418verifyAtomExprTypes _ _ (NakedAtomExpr atom) expectedType = atomTypeVerify expectedType (atomTypeForAtom atom)

409−verifyAtomExprTypes relIn functions (FunctionAtomExpr funcName funcArgExprs) expectedType = do

419+verifyAtomExprTypes relIn context (FunctionAtomExpr funcName funcArgExprs) expectedType = do

420+ let functions = atomFunctions context

410421 func <- atomFunctionForName funcName functions

411422 let expectedArgTypes = atomFuncType func

412− funcArgTypes <- mapM (\(atomExpr,expectedType) -> verifyAtomExprTypes relIn functions atomExpr expectedType) $ zip funcArgExprs expectedArgTypes

423+ funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case verifyAtomExprTypes relIn context atomExpr expectedType2 of

424+ Left (AtomTypeMismatchError expSubType actSubType) -> Left $ AtomFunctionTypeError funcName argCount expSubType actSubType

425+ Left err -> Left err

426+ Right x -> Right x

427+ ) $ zip3 funcArgExprs expectedArgTypes [1..]

413428 if length funcArgTypes /= length expectedArgTypes - 1 then

414429 Left $ AtomTypeCountError funcArgTypes expectedArgTypes

415430 else do

416431 atomTypeVerify expectedType (last expectedArgTypes)

432+verifyAtomExprTypes _ context (RelationAtomExpr relationExpr) expectedType = do

433+ case runState (typeForRelationalExpr relationExpr) context of

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

435+ (Right relType, _) -> atomTypeVerify expectedType (RelationAtomType (attributes relType))

417436

418437--determine if two types are equal or compatible

419438atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

@@ -424,14 +443,17 @@ atomTypeVerify x y = if x == y then

424443 else

425444 Left $ AtomTypeMismatchError x y

426445

427−evalAtomExpr :: RelationTuple -> AtomFunctions -> AtomExpr -> Either RelationalError Atom

446+evalAtomExpr :: RelationTuple -> DatabaseContext -> AtomExpr -> Either RelationalError Atom

428447evalAtomExpr tupIn _ (AttributeAtomExpr attrName) = atomForAttributeName attrName tupIn

429448evalAtomExpr _ _ (NakedAtomExpr atom) = Right atom

430−evalAtomExpr tupIn functions (FunctionAtomExpr funcName arguments) = do

449+evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments) = do

450+ let functions = atomFunctions context

431451 func <- atomFunctionForName funcName functions

432− argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn) functions) arguments

452+ argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn) context) arguments

433453 _ <- mapM (uncurry atomTypeVerify) $ init (zip (atomFuncType func) argTypes)

434− evaldArgs <- mapM (evalAtomExpr tupIn functions) arguments

454+ evaldArgs <- mapM (evalAtomExpr tupIn context) arguments

435455 return $ (atomFunc func) evaldArgs

436−

456+evalAtomExpr _ context (RelationAtomExpr relExpr) = do

457+ relAtom <- evalState (evalRelationalExpr relExpr) context

458+ return $ RelationAtom relAtom

437459

TutorialD/Interpreter.hs+12−10

@@ -53,6 +53,7 @@ lexer = Token.makeTokenParser tutD

5353 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],

5454 Token.reservedNames = [],

5555 Token.identStart = letter <|> char '_',

56+ Token.opLetter = oneOf ":!#$%&*+./<=>?\\^|-~", -- remove "@" so it can be used as attribute marker without spaces

5657 Token.identLetter = alphaNum <|> char '_' <|> char '#'} -- # needed for Date examples

5758

5859parens = Token.parens lexer

@@ -191,15 +192,14 @@ ungroupP = do

191192 rvaAttrName <- identifier

192193 return $ Ungroup (T.pack rvaAttrName)

193194

194−extendP :: Parser RelationalExpr

195+extendP :: Parser (RelationalExpr -> RelationalExpr)

195196extendP = do

196− reservedOp "extend"

197− expr <- relExpr

198197 reservedOp ":"

199198 tupleExpr <- braces tupleExpressionP

200− return $ Extend tupleExpr expr

199+ return $ Extend tupleExpr

201200

202201relOperators = [

202+ [Postfix extendP],

203203 [Postfix projectOp],

204204 [Postfix renameP],

205205 [Postfix whereClauseP],

@@ -211,7 +211,7 @@ relOperators = [

211211 ]

212212

213213relExpr :: Parser RelationalExpr

214−relExpr = extendP <|> buildExpressionParser relOperators relTerm

214+relExpr = buildExpressionParser relOperators relTerm

215215

216216databaseExpr :: Parser DatabaseExpr

217217databaseExpr = insertP

@@ -579,8 +579,8 @@ restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr

579579restrictionAttributeEqualityP = do

580580 attributeName <- identifier

581581 reservedOp "="

582− atom <- stringAtomP <|> intAtomP

583− return $ AttributeEqualityPredicate (T.pack attributeName) atom

582+ atomexpr <- atomExprP

583+ return $ AttributeEqualityPredicate (T.pack attributeName) atomexpr

584584

585585quotedChar = noneOf "\""

586586 <|> try (string "\"\"" >> return '"')

@@ -588,7 +588,7 @@ quotedChar = noneOf "\""

588588stringAtomP = liftA (StringAtom . T.pack) (string "\"" *> many quotedChar <* string "\"")

589589

590590intAtomP = do

591− intstr <- many digit

591+ intstr <- many1 digit

592592 return $ IntAtom (read intstr)

593593

594594--used by :dumpGraph

@@ -612,11 +612,13 @@ attributeTupleExpressionP = do

612612

613613atomExprP :: Parser AtomExpr

614614atomExprP = try functionAtomExprP <|>

615− attributeAtomExprP <|>

616− nakedAtomExprP

615+ attributeAtomExprP <|>

616+ nakedAtomExprP <|>

617+ relationalAtomExprP

617618

618619attributeAtomExprP :: Parser AtomExpr

619620attributeAtomExprP = do

621+ _ <- string "@"

620622 attrName <- identifier

621623 return $ AttributeAtomExpr (T.pack attrName)

622624

test/Relation/Basic.hs+6−1

@@ -9,11 +9,15 @@ import qualified ProjectM36.Attribute as A

99import qualified Data.HashSet as HS

1010import qualified Data.Vector as V

1111import System.Exit

12+import ProjectM36.RelationalExpression

1213

1314testList :: Test

1415testList = TestList [testRelation "relationTrue" relationTrue, testRelation "relationFalse" relationFalse,

1516 testMkRelation1,

16− testRename1, testRename2]

17+ testRename1, testRename2,

18+ testRelation "suppliers" suppliersRel,

19+ testRelation "products" productsRel,

20+ testRelation "supplierProducts" supplierProductsRel]

1721

1822main :: IO ()

1923main = do

@@ -76,3 +80,4 @@ testMkRelation1 = TestCase $ assertEqual "key mismatch" (Left $ TupleAttributeTy

7680 testAttrs = A.attributesFromList [Attribute "a" StringAtomType]

7781 testTupSet = HS.fromList [mkRelationTuple testAttrs $ V.fromList [StringAtom "v"],

7882 mkRelationTuple testAttrs $ V.fromList [IntAtom 2]]

83+

test/TutorialD/Interpreter.hs+10−2

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

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

4646 ("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]])),

4747 ("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])),

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

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

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

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

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

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

4953 ]

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

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

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

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

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

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

5560 dateExampleRelTests = [("x:=S where true", Right suppliersRel),

5661 ("x:=S where CITY = \"London\"", restrict (\tuple -> atomForAttributeName "CITY" tuple == (Right $ StringAtom "London")) suppliersRel),

5762 ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),

5863 ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (A.attributesFromList [ Attribute "STATUS" IntAtomType]) (HS.singleton $ mkRelationTuple (A.attributesFromList [Attribute "STATUS" IntAtomType]) (V.fromList [IntAtom 50]))),

59− ("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)

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

65+ ("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),

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

6067 ]

68+

6169assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion

6270assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted

6371 where