ffd382f · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

implement simple tuple expressions for relational "extend"

ffd382fAgentM11 years ago

ProjectM36/Atom.hs−1

compare with master

unifiedsplit

@@ -11,4 +11,3 @@ atomTypeForAtom :: Atom -> AtomType

11atomTypeForAtom (StringAtom _) = StringAtomType

12atomTypeForAtom (IntAtom _) = IntAtomType

13atomTypeForAtom (RelationAtom (Relation attributes _)) = RelationAtomType attributes

14−

ProjectM36/Attribute.hs+9−9

@@ -59,15 +59,15 @@ renameAttributes oldAttrName newAttrName attrs = V.map renamer attrs

59 else

60 attr

62−atomTypeForAttributeName :: AttributeName -> Attributes -> Maybe AtomType

62+atomTypeForAttributeName :: AttributeName -> Attributes -> Either RelationalError AtomType

63−atomTypeForAttributeName attrName attrs = case attr of

63+atomTypeForAttributeName attrName attrs = do

64− (Just (Attribute _ atype)) -> Just atype

64+ (Attribute _ atype) <- attributeForName attrName attrs

65− _ -> Nothing

65+ return atype

66− where

66+

67− attr = attributeForName attrName attrs

67+attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute

68−

69−attributeForName :: AttributeName -> Attributes -> Maybe Attribute

70−attributeForName attrName attrs = V.find ((attrName ==) . attributeName) attrs

68+attributeForName attrName attrs = case V.find ((attrName ==) . attributeName) attrs of

69+ Nothing -> Left $ NoSuchAttributeNameError attrName

70+ Just attr -> Right attr

72attributesForNames :: S.Set AttributeName -> Attributes -> Attributes

73attributesForNames attrNameSet attrs = V.foldr folder V.empty attrs

ProjectM36/Base.hs+38−6

@@ -17,7 +17,8 @@ type StringType = T.Text

18data Atom = StringAtom StringType |

19 IntAtom Int |

20+ RelationAtom Relation

20− RelationAtom Relation deriving (Show, Eq, Generic)

21+ deriving (Show, Eq, Generic)

22instance NFData Atom where rnf = genericRnf

23instance NFData Atom where rnf = genericRnf

@@ -25,7 +26,9 @@ instance Hash.Hashable Atom

26data AtomType = StringAtomType |

27data AtomType = StringAtomType |

27 IntAtomType |

28 IntAtomType |

28− RelationAtomType Attributes deriving (Eq, Show, Generic)

29+ RelationAtomType Attributes |

30+ AnyAtomType --AnyAtomType is used as a wildcard

31+ deriving (Eq, Show, Generic)

30instance NFData AtomType where rnf = genericRnf

33instance NFData AtomType where rnf = genericRnf

@@ -117,7 +120,8 @@ data RelationalExpr where

117

120

118data DatabaseContext = DatabaseContext {

121data DatabaseContext = DatabaseContext {

119 inclusionDependencies :: HS.HashSet InclusionDependency,

122 inclusionDependencies :: HS.HashSet InclusionDependency,

120− relationVariables :: M.Map RelVarName Relation

123+ relationVariables :: M.Map RelVarName Relation,

124+ atomFunctions :: AtomFunctions

121 } deriving (Show)

125 } deriving (Show)

122

126

123type IncDepName = StringType

127type IncDepName = StringType

@@ -192,7 +196,35 @@ instance Eq Transaction where

192instance Ord Transaction where

196instance Ord Transaction where

193 compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB

197 compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB

194

198

199+--used on the right side of attribute assignments

200+data AtomExpr = AttributeAtomExpr AttributeName |

201+ NakedAtomExpr Atom |

202+ FunctionAtomExpr AtomFunctionName [AtomExpr] |

203+ RelationAtomExpr RelationalExpr

204+ deriving (Eq,Show)

205+

195--used to extend a relation

206--used to extend a relation

196−data TupleExpr = AttributeTupleExpr AttributeName AttributeName |

207+data TupleExpr = AttributeTupleExpr AttributeName AtomExpr

197− MultipleTupleExpr [TupleExpr] --new attr, old attr to clone

208+ deriving (Show, Eq)

198− deriving (Show, Eq)

209+

210+--enumerates the list of functions available to be run as part of tuple expressions

211+type AtomFunctions = HS.HashSet AtomFunction

212+

213+type AtomFunctionName = StringType

214+

215+data AtomFunction = AtomFunction {

216+ atomFuncName :: AtomFunctionName,

217+ atomFuncType :: [AtomType],

218+ atomFunc :: [Atom] -> Atom

219+ }

220+

221+instance Hash.Hashable AtomFunction where

222+ hashWithSalt salt func = salt `Hash.hashWithSalt` (atomFuncName func)

223+

224+instance Eq AtomFunction where

225+ f1 == f2 = (atomFuncName f1) == (atomFuncName f2)

226+

227+instance Show AtomFunction where

228+ show aFunc = T.unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes

229+ where

230+ showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))

ProjectM36/Error.hs+3

@@ -25,6 +25,9 @@ data RelationalError = NoSuchAttributeNameError AttributeName

25 | NoSuchHeadNameError HeadName

26 | TransactionIsNotAHeadError U.UUID

27 | TransactionGraphCycleError U.UUID

28+ | NoSuchTupleExprFunctionError AtomFunctionName

29+ | AtomTypeMismatchError AtomType AtomType

30+ | AtomTypeCountError [AtomType] [AtomType]

28 deriving (Show,Eq,Generic)

31 deriving (Show,Eq,Generic)

ProjectM36/Relation.hs+7−5

@@ -21,13 +21,13 @@ attributes (Relation attrs _ ) = attrs

21attributeNames :: Relation -> S.Set AttributeName

22attributeNames (Relation attrs _) = A.attributeNameSet attrs

24−attributeForName :: AttributeName -> Relation -> Maybe Attribute

24+attributeForName :: AttributeName -> Relation -> Either RelationalError Attribute

25attributeForName attrName (Relation attrs _) = A.attributeForName attrName attrs

27attributesForNames :: S.Set AttributeName -> Relation -> Attributes

28attributesForNames attrNameSet (Relation attrs _) = A.attributesForNames attrNameSet attrs

30−atomTypeForName :: AttributeName -> Relation -> Maybe AtomType

30+atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType

31atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs

33atomValueType :: Atom -> AtomType

@@ -197,9 +197,11 @@ tupleUngroup relvalAttrName newAttrs tuple = do

197 Right accRel -> union accRel $ Relation newAttrs (HS.singleton (tupleExtend nonGroupTupleProjection tupleIn))

198

199attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes

200−attributesForRelval relvalAttrName (Relation attrs _) = case A.atomTypeForAttributeName relvalAttrName attrs of

200+attributesForRelval relvalAttrName (Relation attrs _) = do

201+ atomType <- A.atomTypeForAttributeName relvalAttrName attrs

202+ case atomType of

201− (Just (RelationAtomType relAttrs)) -> Right relAttrs

203+ (RelationAtomType relAttrs) -> Right relAttrs

202− _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName

204+ _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName

203

205

204restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation

206restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation

205--restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset

207--restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset

ProjectM36/RelationalExpression.hs+94−26

@@ -5,13 +5,13 @@ import ProjectM36.Tuple

5import ProjectM36.TupleSet

6import ProjectM36.Base

7import ProjectM36.Error

8+import ProjectM36.Atom

8import qualified ProjectM36.Attribute as A

9import qualified ProjectM36.Attribute as A

9import qualified Data.Map as M

10import qualified Data.Map as M

10import qualified Data.HashSet as HS

11import qualified Data.HashSet as HS

11−import qualified Data.Set as S

12−import qualified Data.Vector as V

13import Control.Monad.State hiding (join)

12import Control.Monad.State hiding (join)

14import Data.Maybe

13import Data.Maybe

14+import Data.Either

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

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

@@ -91,25 +91,31 @@ evalRelationalExpr (Equals relExprA relExprB) = do

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

92evalRelationalExpr (Extend tupleExpression relExpr) = do

93 evald <- evalRelationalExpr relExpr

94+ funcs <- liftM atomFunctions get

94 case evald of

95 case evald of

95 Left err -> return $ Left err

96 Left err -> return $ Left err

96 Right rel -> do

97 Right rel -> do

97− case tupleExpressionProcessor rel tupleExpression of

98+ case tupleExpressionProcessor rel tupleExpression funcs of

98 Left err -> return $ Left err

99 Left err -> return $ Left err

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

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

100

101

101emptyDatabaseContext :: DatabaseContext

102emptyDatabaseContext :: DatabaseContext

102emptyDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

103emptyDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

103− relationVariables = M.empty}

104+ relationVariables = M.empty,

105+ atomFunctions = HS.empty

106+ }

104

107

105basicDatabaseContext :: DatabaseContext

108basicDatabaseContext :: DatabaseContext

106basicDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

109basicDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

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

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

108− ("false", relationFalse)]}

111+ ("false", relationFalse)],

112+ atomFunctions = basicAtomFunctions

113+ }

109

114

110dateExamples :: DatabaseContext

115dateExamples :: DatabaseContext

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

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

112− relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars }

117+ relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,

118+ atomFunctions = basicAtomFunctions}

113 where

119 where

114 dateRelVars = M.fromList [("S", suppliers),

120 dateRelVars = M.fromList [("S", suppliers),

115 ("P", products),

121 ("P", products),

@@ -184,7 +190,7 @@ setRelVar relVarName rel = do

184 case checkConstraints currstate of

190 case checkConstraints currstate of

185 Just err -> return $ Just err

191 Just err -> return $ Just err

186 Nothing -> do

192 Nothing -> do

187− put $ DatabaseContext (inclusionDependencies currstate) newRelVars

193+ put $ DatabaseContext (inclusionDependencies currstate) newRelVars (atomFunctions currstate)

188 return Nothing

194 return Nothing

189

195

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

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

@@ -192,7 +198,7 @@ deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)

192deleteRelVar relVarName = do

198deleteRelVar relVarName = do

193 currstate <- get

199 currstate <- get

194 let newRelVars = M.delete relVarName (relationVariables currstate)

200 let newRelVars = M.delete relVarName (relationVariables currstate)

195− put $ DatabaseContext (inclusionDependencies currstate) newRelVars

201+ put $ DatabaseContext (inclusionDependencies currstate) newRelVars (atomFunctions currstate)

196 return Nothing

202 return Nothing

197

203

198evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)

204evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)

@@ -252,7 +258,7 @@ evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = d

252evalContextExpr (AddInclusionDependency dep) = do

258evalContextExpr (AddInclusionDependency dep) = do

253 currstate <- get

259 currstate <- get

254 let newDeps = HS.insert dep (inclusionDependencies currstate)

260 let newDeps = HS.insert dep (inclusionDependencies currstate)

255− put $ DatabaseContext newDeps (relationVariables currstate)

261+ put $ DatabaseContext newDeps (relationVariables currstate) (atomFunctions currstate)

256 return Nothing

262 return Nothing

257

263

258evalContextExpr (MultipleExpr exprs) = do

264evalContextExpr (MultipleExpr exprs) = do

@@ -313,8 +319,11 @@ typeForRelationalExpr expr = do

313--returns a database context with all tuples removed

319--returns a database context with all tuples removed

314--this is useful for type checking and optimization

320--this is useful for type checking and optimization

315contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext

321contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext

322+contextWithEmptyTupleSets contextIn = DatabaseContext incDeps relVars funcs

323+ where

324+ incDeps = inclusionDependencies contextIn

316−contextWithEmptyTupleSets contextIn = DatabaseContext (inclusionDependencies contextIn) $ M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)

325+ relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)

317−

326+ funcs = atomFunctions contextIn

318

327

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

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

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

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

@@ -347,23 +356,82 @@ predicateRestrictionFilter _ (AttributeEqualityPredicate attrName atom) = Right

347 Left _ -> False

356 Left _ -> False

348 Right atom2 -> atom2 == atom

357 Right atom2 -> atom2 == atom

349

358

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

359+tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation

360+tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then

361+ Left $ AttributeNameInUseError attrName

362+ else

363+ Right rel

351

364

352−--just clone an existing tuple as a new attribute

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

353tupleExpressionProcessor relIn

366tupleExpressionProcessor relIn

354− (AttributeTupleExpr newAttrName oldAttrName) = if isNothing $ attributeForName oldAttrName relIn then

367+ (AttributeTupleExpr newAttrName atomExpr) functions = do

355− Left $ NoSuchAttributeNameError oldAttrName

368+ _ <- tupleExprCheckNewAttrName newAttrName relIn

356− else if isJust $ attributeForName newAttrName relIn then

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

357− Left $ AttributeNameInUseError newAttrName

370+ _ <- verifyAtomExprTypes relIn functions atomExpr atomExprType

358− else do

371+ let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType]

359− let newAttrs = A.renameAttributes oldAttrName newAttrName (attributesForNames (S.singleton oldAttrName) relIn)

360− let newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

372+ newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

361− return $ (newAndOldAttrs, \tup -> tupleExtend tup (RelationTuple newAttrs (atomsForAttributeNames (V.singleton oldAttrName) tup)))

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

374+ Left _ -> undefined -- ?!

375+ Right atom -> tupleAtomExtend newAttrName atom tup)

376+

377+basicAtomFunctions :: AtomFunctions

378+basicAtomFunctions = HS.fromList [

379+ --match on any relation type

380+ AtomFunction "add" [IntAtomType, IntAtomType, IntAtomType] (\(i1:i2:_) -> (\(IntAtom a) (IntAtom b) -> IntAtom (a + b)) i1 i2),

381+ AtomFunction { atomFuncName = "id",

382+ atomFuncType = [AnyAtomType],

383+ atomFunc = (\(x:_) -> x)}

362

384

363−tupleExpressionProcessor relIn (MultipleTupleExpr exprList) = do

385+-- AtomFunction "count" [RelationAtomType , IntAtom],

364− procList <- mapM (tupleExpressionProcessor relIn) exprList

386+-- AtomFunction "sum" [RelationAtomType IntAtomType

365− -- add up all the new attributes from the procList

387+ ]

366− let folder (attrs, tupProc) (accAttrs, accTupProc) = (A.addAttributes attrs accAttrs, tupProc . accTupProc)

367− return $ foldl folder (A.emptyAttributes, id) procList

368

388

389+atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction

390+atomFunctionForName funcName funcSet = if HS.null foundFunc then

391+ Left $ NoSuchTupleExprFunctionError funcName

392+ else

393+ Right $ head $ HS.toList foundFunc

394+ where

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

396+

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

398+typeFromAtomExpr attrs _ (AttributeAtomExpr attrName) = A.atomTypeForAttributeName attrName attrs

399+typeFromAtomExpr _ _ (NakedAtomExpr atom) = Right (atomTypeForAtom atom)

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

401+ func <- atomFunctionForName funcName funcs

402+ return $ last (atomFuncType func)

369

403

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

405+verifyAtomExprTypes relIn _ (AttributeAtomExpr attrName) expectedType = do

406+ attrType <- A.atomTypeForAttributeName attrName (attributes relIn)

407+ atomTypeVerify expectedType attrType

408+verifyAtomExprTypes _ _ (NakedAtomExpr atom) expectedType = atomTypeVerify expectedType (atomTypeForAtom atom)

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

410+ func <- atomFunctionForName funcName functions

411+ let expectedArgTypes = atomFuncType func

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

413+ if length funcArgTypes /= length expectedArgTypes - 1 then

414+ Left $ AtomTypeCountError funcArgTypes expectedArgTypes

415+ else do

416+ atomTypeVerify expectedType (last expectedArgTypes)

417+

418+--determine if two types are equal or compatible

419+atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

420+atomTypeVerify AnyAtomType x = Right x

421+atomTypeVerify x AnyAtomType = Right x

422+atomTypeVerify x y = if x == y then

423+ Right x

424+ else

425+ Left $ AtomTypeMismatchError x y

426+

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

428+evalAtomExpr tupIn _ (AttributeAtomExpr attrName) = atomForAttributeName attrName tupIn

429+evalAtomExpr _ _ (NakedAtomExpr atom) = Right atom

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

431+ func <- atomFunctionForName funcName functions

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

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

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

435+ return $ (atomFunc func) evaldArgs

436+

437+

ProjectM36/Tuple.hs+19−7

@@ -32,6 +32,13 @@ atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex

32 Just index -> case tupVec V.!? index of

33 Nothing -> Left $ NoSuchAttributeNameError attrName

34 Just atom -> Right atom

35+

36+{- -- resolve naming clash with Attribute and Relation later

37+atomTypeForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom

38+atomTypeForAttributeName attrName tup = do

39+ atom <- atomForAttributeName attrName tup

40+ return $ atomTypeForAtom atom

41+-}

36atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> V.Vector Atom

43atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> V.Vector Atom

37atomsForAttributeNames attrNames tuple = V.foldr folder V.empty attrNames

44atomsForAttributeNames attrNames tuple = V.foldr folder V.empty attrNames

@@ -41,13 +48,13 @@ atomsForAttributeNames attrNames tuple = V.foldr folder V.empty attrNames

41 Right atom -> V.snoc acc atom

48 Right atom -> V.snoc acc atom

43relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation

50relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation

44−relationForAttributeName attrName tuple = if maybe False isRelationAtomType (atomTypeForAttributeName attrName (tupleAttributes tuple)) then

51+relationForAttributeName attrName tuple = do

52+ aType <- atomTypeForAttributeName attrName (tupleAttributes tuple)

53+ if not (isRelationAtomType aType) then

45− Left $ AttributeIsNotRelationValuedError attrName

54+ Left $ AttributeIsNotRelationValuedError attrName

46− else do

55+ else do

47− atomVal <- atomForAttributeName attrName tuple

56+ atomVal <- atomForAttributeName attrName tuple

48− relationForAtom atomVal

57+ relationForAtom atomVal

49−

50−

52--in case the oldattr does not exist in the tuple, then return the old tuple

59--in case the oldattr does not exist in the tuple, then return the old tuple

53tupleRenameAttribute :: AttributeName -> AttributeName -> RelationTuple -> RelationTuple

60tupleRenameAttribute :: AttributeName -> AttributeName -> RelationTuple -> RelationTuple

@@ -103,6 +110,11 @@ tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2)

103 where

110 where

104 newAttrs = tupAttrs1 V.++ tupAttrs2

111 newAttrs = tupAttrs1 V.++ tupAttrs2

105 newVec = tupVec1 V.++ tupVec2

112 newVec = tupVec1 V.++ tupVec2

113+

114+tupleAtomExtend :: AttributeName -> Atom -> RelationTuple -> RelationTuple

115+tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup

116+ where

117+ newTup = RelationTuple (V.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)

106

118

107{- sort the associative list to match the header sorting -}

119{- sort the associative list to match the header sorting -}

108tupleSortedAssocs :: RelationTuple -> [(AttributeName, Atom)]

120tupleSortedAssocs :: RelationTuple -> [(AttributeName, Atom)]

TutorialD/Interpreter.hs+26−5

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

21import qualified Data.HashSet as HS

22import qualified Data.Map as M

23import qualified Data.List as L

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

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

25import Control.Monad.State

26import System.Console.Haskeline

27import System.IO

@@ -597,8 +597,8 @@ displayTransactionGraph :: TransactionGraph -> String

597displayTransactionGraph (TransactionGraph _ transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet

598-}

599

600−multiTupleExpressionP :: Parser TupleExpr

600+multiTupleExpressionP :: Parser [TupleExpr]

601−multiTupleExpressionP = MultipleTupleExpr <$> (sepBy tupleExpressionP comma)

601+multiTupleExpressionP = sepBy tupleExpressionP comma

602

603tupleExpressionP :: Parser TupleExpr

604tupleExpressionP = attributeTupleExpressionP

@@ -607,6 +607,27 @@ attributeTupleExpressionP :: Parser TupleExpr

607attributeTupleExpressionP = do

608 newAttr <- identifier

609 reservedOp ":="

610− attr <- identifier

610+ atom <- atomExprP

611− return $ AttributeTupleExpr (T.pack newAttr) (T.pack attr)

611+ return $ AttributeTupleExpr (T.pack newAttr) atom

612

613+atomExprP :: Parser AtomExpr

614+atomExprP = try functionAtomExprP <|>

615+ attributeAtomExprP <|>

616+ nakedAtomExprP

617+

618+attributeAtomExprP :: Parser AtomExpr

619+attributeAtomExprP = do

620+ attrName <- identifier

621+ return $ AttributeAtomExpr (T.pack attrName)

622+

623+nakedAtomExprP :: Parser AtomExpr

624+nakedAtomExprP = NakedAtomExpr <$> (stringAtomP <|> intAtomP)

625+

626+functionAtomExprP :: Parser AtomExpr

627+functionAtomExprP = do

628+ funcName <- identifier

629+ argList <- parens (sepBy atomExprP comma)

630+ return $ FunctionAtomExpr (T.pack funcName) argList

631+

632+relationalAtomExprP :: Parser AtomExpr

633+relationalAtomExprP = RelationAtomExpr <$> relExpr

test/Relation/Basic.hs+1−1

@@ -50,7 +50,7 @@ validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = HS.foldr (\tu

50 tupleAtomCheck tuple = V.all (== True) (attrChecks tuple)

51 attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of

52 Left _ -> False

53− Right atom -> (Just $ atomTypeForAtom atom) ==

53+ Right atom -> (Right $ atomTypeForAtom atom) ==

54 A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)

56simpleRel :: Relation