master...00f1365 · project-m36

project-m36.cabal+1

since splitsnapshots

unifiedsplit

@@ -81,6 +81,7 @@ Library

81 ProjectM36.Atom,

82 ProjectM36.AtomFunction,

83 ProjectM36.AtomFunctionError,

84+ ProjectM36.TupleFunction,

84 ProjectM36.ScriptSession,

85 ProjectM36.ScriptSession,

85 ProjectM36.DatabaseContextFunction,

86 ProjectM36.DatabaseContextFunction,

86 ProjectM36.DatabaseContextFunctionError,

87 ProjectM36.DatabaseContextFunctionError,

src/lib/ProjectM36/Atom.hs+3−1

@@ -19,8 +19,10 @@ makeAtomFromText _ DayAtomType textIn = maybe ((Left . ParseError) textIn) (Righ

19makeAtomFromText _ DateTimeAtomType textIn = maybe ((Left . ParseError) textIn) (Right . DateTimeAtom) (readMaybe (T.unpack textIn))

20makeAtomFromText _ ByteStringAtomType textIn = maybe ((Left . ParseError) textIn) (Right . ByteStringAtom) (readMaybe (T.unpack textIn))

21makeAtomFromText _ BoolAtomType textIn = maybe ((Left . ParseError) textIn) (Right . BoolAtom) (readMaybe (T.unpack textIn))

22+makeAtomFromText attrName TupleFunctionAtomType _ = Left (AtomTypeNotSupported attrName)

22makeAtomFromText attrName _ _ = Left $ AtomTypeNotSupported attrName

23makeAtomFromText attrName _ _ = Left $ AtomTypeNotSupported attrName

23

24

25+

24atomToText :: Atom -> T.Text

26atomToText :: Atom -> T.Text

25atomToText (IntAtom i) = (T.pack . show) i

27atomToText (IntAtom i) = (T.pack . show) i

26atomToText (DoubleAtom i) = (T.pack . show) i

28atomToText (DoubleAtom i) = (T.pack . show) i

@@ -31,6 +33,6 @@ atomToText (ByteStringAtom i) = (T.pack . show) i

31atomToText (BoolAtom i) = (T.pack . show) i

33atomToText (BoolAtom i) = (T.pack . show) i

32atomToText (RelationAtom i) = (T.pack . show) i

34atomToText (RelationAtom i) = (T.pack . show) i

33atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms)

35atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms)

34−

36+atomToText (TupleFunctionAtom _) = "<TupleFunctionAtom>"

35

37

36

38

src/lib/ProjectM36/Base.hs+18−2

@@ -3,6 +3,7 @@

3module ProjectM36.Base where

4import ProjectM36.DatabaseContextFunctionError

5import ProjectM36.AtomFunctionError

6+import ProjectM36.TupleFunctionError

6

7

7import qualified Data.Map as M

8import qualified Data.Map as M

8import qualified Data.HashSet as HS

9import qualified Data.HashSet as HS

@@ -35,9 +36,12 @@ data Atom = IntAtom Int |

35 ByteStringAtom ByteString |

36 ByteStringAtom ByteString |

36 BoolAtom Bool |

37 BoolAtom Bool |

37 RelationAtom Relation |

38 RelationAtom Relation |

38− ConstructedAtom DataConstructorName AtomType [Atom]

39+ ConstructedAtom DataConstructorName AtomType [Atom] |

40+ TupleFunctionAtom TupleFunctionName -- a function stored as an atom that runs on the current tuple

39 deriving (Eq, Show, Binary, Typeable, NFData, Generic)

41 deriving (Eq, Show, Binary, Typeable, NFData, Generic)

40

42

43+type TupleFunctionName = StringType

44+

41instance Hashable Atom where

45instance Hashable Atom where

42 hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms

46 hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms

43 `hashWithSalt` dConsName --AtomType is not hashable

47 `hashWithSalt` dConsName --AtomType is not hashable

@@ -49,6 +53,7 @@ instance Hashable Atom where

49 hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs

53 hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs

50 hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b

54 hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b

51 hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r

55 hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r

56+ hashWithSalt salt (TupleFunctionAtom nam) = salt `hashWithSalt` nam

52

57

53instance Binary UTCTime where

58instance Binary UTCTime where

54 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)

59 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)

@@ -73,6 +78,7 @@ data AtomType = IntAtomType |

73 BoolAtomType |

78 BoolAtomType |

74 RelationAtomType Attributes |

79 RelationAtomType Attributes |

75 ConstructedAtomType TypeConstructorName TypeVarMap |

80 ConstructedAtomType TypeConstructorName TypeVarMap |

81+ TupleFunctionAtomType |

76 TypeVariableType TypeVarName

82 TypeVariableType TypeVarName

77 --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor

83 --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor

78 deriving (Eq, NFData, Generic, Binary, Show)

84 deriving (Eq, NFData, Generic, Binary, Show)

@@ -273,6 +279,15 @@ data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarNam

273 deriving (Generic, Binary, Show)

279 deriving (Generic, Binary, Show)

274

280

275type SchemaIsomorphs = [SchemaIsomorph]

281type SchemaIsomorphs = [SchemaIsomorph]

282+

283+type TupleFunctionScript = StringType

284+

285+type TupleFunctionBodyType = RelationTuple -> Either TupleFunctionError Atom

286+

287+data TupleFunction = TupleFunction (Maybe TupleFunctionScript) TupleFunctionBodyType

288+ deriving (Generic, NFData)

289+

290+type TupleFunctions = M.Map TupleFunctionName TupleFunction

276

291

277data DatabaseContext = DatabaseContext {

292data DatabaseContext = DatabaseContext {

278 inclusionDependencies :: InclusionDependencies,

293 inclusionDependencies :: InclusionDependencies,

@@ -280,7 +295,8 @@ data DatabaseContext = DatabaseContext {

280 atomFunctions :: AtomFunctions,

295 atomFunctions :: AtomFunctions,

281 dbcFunctions :: DatabaseContextFunctions,

296 dbcFunctions :: DatabaseContextFunctions,

282 notifications :: Notifications,

297 notifications :: Notifications,

283− typeConstructorMapping :: TypeConstructorMapping

298+ typeConstructorMapping :: TypeConstructorMapping,

299+ tupleFunctions :: TupleFunctions

284 } deriving (NFData, Generic)

300 } deriving (NFData, Generic)

285

301

286type IncDepName = StringType

302type IncDepName = StringType

src/lib/ProjectM36/DataTypes/Primitive.hs+1

@@ -35,3 +35,4 @@ atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType

35atomTypeForAtom (BoolAtom _) = BoolAtomType

36atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs

37atomTypeForAtom (ConstructedAtom _ aType _) = aType

38+atomTypeForAtom (TupleFunctionAtom _) = TupleFunctionAtomType

src/lib/ProjectM36/DatabaseContext.hs+4−2

@@ -13,7 +13,8 @@ empty = DatabaseContext { inclusionDependencies = M.empty,

13 notifications = M.empty,

14 atomFunctions = HS.empty,

15 dbcFunctions = HS.empty,

16− typeConstructorMapping = [] }

16+ typeConstructorMapping = [],

17+ tupleFunctions = M.empty }

17

18

18-- | convert an existing database context into its constituent expression.

19-- | convert an existing database context into its constituent expression.

19databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

20databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

@@ -31,5 +32,6 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

31 atomFunctions = basicAtomFunctions,

32 atomFunctions = basicAtomFunctions,

32 dbcFunctions = basicDatabaseContextFunctions,

33 dbcFunctions = basicDatabaseContextFunctions,

33 notifications = M.empty,

34 notifications = M.empty,

34− typeConstructorMapping = basicTypeConstructorMapping

35+ typeConstructorMapping = basicTypeConstructorMapping,

36+ tupleFunctions = M.empty

35 }

37 }

src/lib/ProjectM36/RelationalExpression.hs+9−1

@@ -6,6 +6,7 @@ import ProjectM36.TupleSet

6import ProjectM36.Base

7import ProjectM36.Error

8import ProjectM36.AtomType

9+import ProjectM36.TupleFunction

9import ProjectM36.Attribute (emptyAttributes)

10import ProjectM36.Attribute (emptyAttributes)

10import ProjectM36.ScriptSession

11import ProjectM36.ScriptSession

11import ProjectM36.DataTypes.Primitive

12import ProjectM36.DataTypes.Primitive

@@ -670,7 +671,14 @@ evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExcept

670 aType <- either throwE pure (evalState (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)

671 aType <- either throwE pure (evalState (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)

671 argAtoms <- mapM (\arg -> either throwE pure (evalState (evalAtomExpr tupIn arg) newState)) dConsArgs

672 argAtoms <- mapM (\arg -> either throwE pure (evalState (evalAtomExpr tupIn arg) newState)) dConsArgs

672 pure (ConstructedAtom dConsName aType argAtoms)

673 pure (ConstructedAtom dConsName aType argAtoms)

673−

674+evalAtomExpr tupIn (TupleFunctionAtom tfName) = do

675+ rstate <- get

676+ let context = stateContext rstate

677+ functions = tupleFunctions context

678+ runExceptT $ do

679+ func <- either throwE pure (tupleFunctionForName tfName functions)

680+ --validate argument types

681+

674typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)

682typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)

675typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

683typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

676 --first, check if the attribute is in the immediate attributes

684 --first, check if the attribute is in the immediate attributes

src/lib/ProjectM36/Transaction/Persist.hs+2−1

@@ -72,7 +72,8 @@ readTransaction dbdir transId mScriptSession = do

72 typeConstructorMapping = typeCons,

73 notifications = M.empty,

74 atomFunctions = atomFuncs,

75− dbcFunctions = dbcFuncs }

75+ dbcFunctions = dbcFuncs,

76+ tupleFunctions = undefined}

76 newSchemas = Schemas newContext sschemas

77 newSchemas = Schemas newContext sschemas

77 return $ Right $ Transaction transId transInfo newSchemas

78 return $ Right $ Transaction transId transInfo newSchemas

78

79

src/lib/ProjectM36/TransactionGraph.hs+3−1

@@ -426,6 +426,7 @@ createUnionMergeTransaction newId strategy graph (t1,t2) = do

426 atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)

427 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)

428 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)

429+ let tupleFuncs = M.union (tupleFunctions contextA) (tupleFunctions contextB)

429 -- TODO: add merge of subschemas

430 -- TODO: add merge of subschemas

430 let newContext = DatabaseContext {

431 let newContext = DatabaseContext {

431 inclusionDependencies = incDeps,

432 inclusionDependencies = incDeps,

@@ -433,7 +434,8 @@ createUnionMergeTransaction newId strategy graph (t1,t2) = do

433 atomFunctions = atomFuncs,

434 atomFunctions = atomFuncs,

434 dbcFunctions = undefined,

435 dbcFunctions = undefined,

435 notifications = notifs,

436 notifications = notifs,

436− typeConstructorMapping = types

437+ typeConstructorMapping = types,

438+ tupleFunctions = tupleFuncs

437 }

439 }

438 newSchemas = Schemas newContext (subschemas t1)

440 newSchemas = Schemas newContext (subschemas t1)

439 pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) newSchemas)

441 pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) newSchemas)

src/lib/ProjectM36/TupleFunction.hsnew file+9

@@ -0,0 +1,9 @@

1+module ProjectM36.TupleFunction where

2+import ProjectM36.Base

3+import qualified Data.Map as M

4+import ProjectM36.Error

5+

6+tupleFunctionForName :: TupleFunctionName -> TupleFunctions -> Either RelationalError TupleFunction

7+tupleFunctionForName fName funcs = case M.lookup fName funcs of

8+ Nothing -> Left (NoSuchFunctionError fName)

9+ Just f -> Right f

src/lib/ProjectM36/TupleFunctionError.hsnew file+3

@@ -0,0 +1,3 @@

1+module ProjectM36.TupleFunctionError where

2+

3+data TupleFunctionError = FunctionPooped