@@ -5,20 +5,19 @@ import ProjectM36.Tuple
55import ProjectM36.TupleSet
66import ProjectM36.Base
77import ProjectM36.Error
8−import ProjectM36.Atom
98import ProjectM36.AtomType
10−import ProjectM36.Key
9+import ProjectM36.DataTypes.Primitive
1110import ProjectM36.AtomFunction
12−import ProjectM36.DataTypes.Interval
1311import qualified ProjectM36.Attribute as A
1412import qualified Data.Map as M
1513import qualified Data.HashSet as HS
16−import qualified Data.Set as S
1714import Control.Monad.State hiding (join)
1815import Data.Maybe
1916import Data.Either
2017import Data.Char (isUpper)
2118import qualified Data.Text as T
19+import qualified Data.Vector as V
20+--import Debug.Trace
2221
2322--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
2423evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
@@ -56,7 +55,27 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do
5655 case mkRelation attributeSet tupleSet of
5756 Right rel -> return $ Right rel
5857 Left err -> return $ Left err
59−
58+
59+evalRelationalExpr (MakeEmptyRelation attrExprs) = do
60+ currentContext <- get
61+ let eAttrs = map (evalAttrExpr (atomTypes currentContext)) attrExprs
62+ case lefts eAttrs of
63+ err:_ -> pure (Left err)
64+ [] -> pure $ mkRelation (A.attributesFromList (rights eAttrs)) emptyTupleSet
65+
66+evalRelationalExpr (MakeRelationFromTupleExprs tupleExprs) = do
67+ currentContext <- get
68+ if null tupleExprs then
69+ pure $ Left CouldNotInferAttributes
70+ else
71+ let eTuples = map (evalTupleExpr currentContext) tupleExprs in
72+ case lefts eTuples of
73+ err:_ -> pure (Left err)
74+ [] -> case head eTuples of
75+ Left err -> error $ "impossible Right err " ++ show err
76+ --extract potential attributes from first tuple
77+ Right firstTuple -> pure $ mkRelation (tupleAttributes firstTuple) (RelationTupleSet (rights eTuples))
78+
6079evalRelationalExpr (ExistingRelation rel) = return (Right rel)
6180
6281evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
@@ -112,7 +131,7 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do
112131 case evald of
113132 Left err -> return $ Left err
114133 Right rel -> do
115− case tupleExpressionProcessor rel tupleExpression context of
134+ case extendTupleExpressionProcessor rel tupleExpression context of
116135 Left err -> return $ Left err
117136 Right (newAttrs, tupProc) -> return $ relMogrify tupProc newAttrs rel
118137
@@ -124,91 +143,7 @@ emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
124143 atomTypes = M.empty
125144 }
126145
127−basicDatabaseContext :: DatabaseContext
128−basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
129− relationVariables = M.fromList [("true", relationTrue),
130− ("false", relationFalse)],
131− atomFunctions = basicAtomFunctions,
132− notifications = M.empty,
133− atomTypes = basicAtomTypes
134− }
135146
136−dateExamples :: DatabaseContext
137−dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,
138− relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,
139− notifications = M.empty,
140− atomFunctions = basicAtomFunctions,
141− atomTypes = basicAtomTypes }
142− where
143− dateRelVars = M.fromList [("S", suppliers),
144− ("P", products),
145− ("SP", supplierProducts)]
146− suppliers = suppliersRel
147− products = productsRel
148− supplierProducts = supplierProductsRel
149− dateIncDeps = M.fromList [("S_pkey", simplePKey ["S#"] "S"),
150− ("P_pkey", simplePKey ["P#"] "P"),
151− ("SP_pkey", simplePKey ["S#", "P#"] "SP")
152− ]
153− simplePKey attrNames relvarName = inclusionDependencyForKey (AttributeNames $ S.fromList attrNames) (RelationVariable relvarName)
154−
155−suppliersRel :: Relation
156−suppliersRel = case mkRelationFromList attrs atomMatrix of
157− Left _ -> undefined
158− Right rel -> rel
159− where
160− attrs = A.attributesFromList [Attribute "S#" stringAtomType,
161− Attribute "SNAME" stringAtomType,
162− Attribute "STATUS" intAtomType,
163− Attribute "CITY" stringAtomType]
164− atomMatrix = [
165− [stringAtom "S1", stringAtom "Smith", intAtom 20, stringAtom "London"],
166− [stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"],
167− [stringAtom "S3", stringAtom "Blake", intAtom 30, stringAtom "Paris"],
168− [stringAtom "S4", stringAtom "Clark", intAtom 20, stringAtom "London"],
169− [stringAtom "S5", stringAtom "Adams", intAtom 30, stringAtom "Athens"]]
170−
171−supplierProductsRel :: Relation
172−supplierProductsRel = case mkRelationFromList attrs matrix of
173− Left _ -> undefined
174− Right rel -> rel
175− where
176− attrs = A.attributesFromList [Attribute "S#" stringAtomType,
177− Attribute "P#" stringAtomType,
178− Attribute "QTY" intAtomType]
179− matrix = [
180− [stringAtom "S1", stringAtom "P1", intAtom 300],
181− [stringAtom "S1", stringAtom "P2", intAtom 200],
182− [stringAtom "S1", stringAtom "P3", intAtom 400],
183− [stringAtom "S1", stringAtom "P4", intAtom 200],
184− [stringAtom "S1", stringAtom "P5", intAtom 100],
185− [stringAtom "S1", stringAtom "P6", intAtom 100],
186− [stringAtom "S2", stringAtom "P1", intAtom 300],
187− [stringAtom "S2", stringAtom "P2", intAtom 400],
188− [stringAtom "S3", stringAtom "P2", intAtom 200],
189− [stringAtom "S4", stringAtom "P2", intAtom 200],
190− [stringAtom "S4", stringAtom "P4", intAtom 300],
191− [stringAtom "S4", stringAtom "P5", intAtom 400]
192− ]
193−
194−productsRel :: Relation
195−productsRel = case mkRelationFromList attrs matrix of
196− Left _ -> undefined
197− Right rel -> rel
198− where
199− attrs = A.attributesFromList [Attribute "P#" stringAtomType,
200− Attribute "PNAME" stringAtomType,
201− Attribute "COLOR" stringAtomType,
202− Attribute "WEIGHT" intAtomType,
203− Attribute "CITY" stringAtomType]
204− matrix = [
205− [stringAtom "P1", stringAtom "Nut", stringAtom "Red", intAtom 12, stringAtom "London"],
206− [stringAtom "P2", stringAtom "Bolt", stringAtom "Green", intAtom 17, stringAtom "Paris"],
207− [stringAtom "P3", stringAtom "Screw", stringAtom "Blue", intAtom 17, stringAtom "Oslo"],
208− [stringAtom "P4", stringAtom "Screw", stringAtom "Red", intAtom 14, stringAtom "London"],
209− [stringAtom "P5", stringAtom "Cam", stringAtom "Blue", intAtom 12, stringAtom "Paris"],
210− [stringAtom "P6", stringAtom "Cog", stringAtom "Red", intAtom 19, stringAtom "London"]
211− ]
212147
213148--helper function to process relation variable creation/assignment
214149setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)
@@ -231,13 +166,18 @@ deleteRelVar relVarName = do
231166 return Nothing
232167
233168evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)
234−evalContextExpr (Define relVarName attrs) = do
169+evalContextExpr (Define relVarName attrExprs) = do
235170 relvars <- liftM relationVariables get
236− case M.member relVarName relvars of
237− True -> return (Just (RelVarAlreadyDefinedError relVarName))
238− False -> setRelVar relVarName emptyRelation
239− where
240− emptyRelation = Relation attrs emptyTupleSet
171+ aTypes <- liftM atomTypes get
172+ let eAttrs = map (evalAttrExpr aTypes) attrExprs
173+ case lefts eAttrs of
174+ err:_ -> pure (Just err)
175+ [] -> case M.member relVarName relvars of
176+ True -> return (Just (RelVarAlreadyDefinedError relVarName))
177+ False -> setRelVar relVarName emptyRelation
178+ where
179+ attrs = A.attributesFromList (rights eAttrs)
180+ emptyRelation = Relation attrs emptyTupleSet
241181
242182evalContextExpr (Undefine relVarName) = do
243183 deleteRelVar relVarName
@@ -335,16 +275,18 @@ evalContextExpr (RemoveNotification notName) = do
335275
336276-- | Adds type and data constructors to the database context.
337277-- validate that the type *and* constructor names are unique! not yet implemented!
338−evalContextExpr (AddAtomConstructor tConsName atomConstructor) = do
278+evalContextExpr (AddAtomConstructor tConsName atomC@(AtomConstructor atomConsMap)) = do
339279 currentContext <- get
340280 let oldAtomTypes = atomTypes currentContext
281+ -- validate that the constructor's types exist
282+ -- atomAndArgsTypesForDataConstructorName oldAtomTypes
341283 if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then
342284 pure $ Just (InvalidAtomTypeName tConsName)
343285 else if M.member tConsName oldAtomTypes then
344286 pure $ Just (AtomTypeNameInUseError tConsName)
345287 else do
346288 let newAtomTypes = M.insert tConsName newType oldAtomTypes
347− newType = (ConstructedAtomType tConsName, atomConstructor)
289+ newType = (ConstructedAtomType tConsName, atomC)
348290 put $ currentContext { atomTypes = newAtomTypes }
349291 pure Nothing
350292
@@ -475,8 +417,8 @@ tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName
475417 else
476418 Right rel
477419
478−tupleExpressionProcessor :: Relation -> TupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)
479−tupleExpressionProcessor relIn
420+extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)
421+extendTupleExpressionProcessor relIn
480422 (AttributeExtendTupleExpr newAttrName atomExpr) context = do
481423 _ <- tupleExprCheckNewAttrName newAttrName relIn
482424 atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr
@@ -525,7 +467,7 @@ typeFromAtomExpr attrs context (ConstructedAtomExpr dConsName dConsArgs) = do
525467 else
526468 pure tConsType
527469
528−-- | Validae that the
470+-- | Validate that the type of the AtomExpr matches the expected type.
529471verifyAtomExprTypes :: Relation -> DatabaseContext -> AtomExpr -> AtomType -> Either RelationalError AtomType
530472verifyAtomExprTypes relIn _ (AttributeAtomExpr attrName) expectedType = do
531473 attrType <- A.atomTypeForAttributeName attrName (attributes relIn)
@@ -553,52 +495,21 @@ verifyAtomExprTypes rel context cons@(ConstructedAtomExpr _ _) expectedType = do
553495 atomTypeVerify expectedType cType
554496
555497
556−
557−basicAtomFunctions :: AtomFunctions
558−basicAtomFunctions = HS.fromList $ [
559− --match on any relation type
560− AtomFunction { atomFuncName = "add",
561− atomFuncType = [intAtomType, intAtomType, intAtomType],
562− atomFunc = (\(i1:i2:_) -> Atom $ ((unsafeCast i1)::Int) + unsafeCast i2)},
563− AtomFunction { atomFuncName = "id",
564− atomFuncType = [AnyAtomType, AnyAtomType],
565− atomFunc = (\(x:_) -> x)},
566− AtomFunction { atomFuncName = "sum",
567− atomFuncType = foldAtomFuncType intAtomType intAtomType,
568− atomFunc = (\(relAtom:_) -> relationSum $ unsafeCast relAtom)},
569− AtomFunction { atomFuncName = "count",
570− atomFuncType = foldAtomFuncType AnyAtomType intAtomType,
571− atomFunc = (\((relIn):_) -> relationCount (castRelation relIn))},
572− AtomFunction { atomFuncName = "max",
573− atomFuncType = foldAtomFuncType intAtomType intAtomType,
574− atomFunc = (\((relIn):_) -> relationMax (castRelation relIn))},
575− AtomFunction { atomFuncName = "min",
576− atomFuncType = foldAtomFuncType intAtomType intAtomType,
577− atomFunc = (\((relIn):_) -> relationMin (castRelation relIn))},
578− AtomFunction { atomFuncName = "lt",
579− atomFuncType = [intAtomType, intAtomType, boolAtomType],
580− atomFunc = intAtomFuncLessThan False},
581− AtomFunction { atomFuncName = "lte",
582− atomFuncType = [intAtomType, intAtomType, boolAtomType],
583− atomFunc = intAtomFuncLessThan True},
584− AtomFunction { atomFuncName = "gte",
585− atomFuncType = [intAtomType, intAtomType, boolAtomType],
586− atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan False},
587− AtomFunction { atomFuncName = "gt",
588− atomFuncType = [intAtomType, intAtomType, boolAtomType],
589− atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan True},
590− AtomFunction { atomFuncName = "not",
591− atomFuncType = [boolAtomType, boolAtomType],
592− atomFunc = boolAtomNot}
593− ] ++ intervalFunctions
594−
595−intAtomFuncLessThan :: Bool -> [Atom] -> Atom
596−intAtomFuncLessThan equality (iatom1:iatom2:_) = (\i1 i2 -> Atom $ ((unsafeCast i1)::Int) `op` unsafeCast i2) iatom1 iatom2
597− where
598− op = if equality then (<=) else (<)
599−intAtomFuncLessThan _ _= Atom False
600−
601−boolAtomNot :: [Atom] -> Atom
602−boolAtomNot (bool:_) = Atom $ not (unsafeCast bool)
603−boolAtomNot _ = Atom False
604−
498+-- | Look up the type's name and create a new attribute.
499+evalAttrExpr :: AtomTypes -> AttributeExpr -> Either RelationalError Attribute
500+evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tConsName) = do
501+ aType <- atomTypeForTypeConstructor tConsName aTypes
502+ Right (Attribute attrName aType)
503+
504+evalTupleExpr :: DatabaseContext -> TupleExpr -> Either RelationalError RelationTuple
505+evalTupleExpr context (TupleExpr tupMap) = do
506+ -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority
507+ attrAtoms <- mapM (\(attrName, aExpr) -> do
508+ newAtom <- evalAtomExpr emptyTuple context aExpr
509+ newAtomType <- typeFromAtomExpr A.emptyAttributes context aExpr
510+ pure (attrName, newAtom, newAtomType)
511+ ) (M.toList tupMap)
512+ let attrs = map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
513+ atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
514+ pure $ mkRelationTuple (A.attributesFromList attrs) atoms
515+