00f1365 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP tuple functions

commit00f13651d170a79de971b6f5661897d7d6a94bd2 authorAgentM <agentm@themactionfaction.com> dateFri 19 May 2017, 08:26 (9 years ago) parent448197c

10 files changed+53−8

compare with master

unifiedsplit

project-m36.cabal+1 src/lib/ProjectM36/Atom.hs+3−1 src/lib/ProjectM36/Base.hs+18−2 src/lib/ProjectM36/DataTypes/Primitive.hs+1 src/lib/ProjectM36/DatabaseContext.hs+4−2 src/lib/ProjectM36/RelationalExpression.hs+9−1 src/lib/ProjectM36/Transaction/Persist.hs+2−1 src/lib/ProjectM36/TransactionGraph.hs+3−1 src/lib/ProjectM36/TupleFunction.hs+9 src/lib/ProjectM36/TupleFunctionError.hs+3

project-m36.cabal+1

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

8181 ProjectM36.Atom,

8282 ProjectM36.AtomFunction,

8383 ProjectM36.AtomFunctionError,

84+ ProjectM36.TupleFunction,

8485 ProjectM36.ScriptSession,

8586 ProjectM36.DatabaseContextFunction,

8687 ProjectM36.DatabaseContextFunctionError,

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

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

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

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

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

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

2223makeAtomFromText attrName _ _ = Left $ AtomTypeNotSupported attrName

2324

25+

2426atomToText :: Atom -> T.Text

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

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

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

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

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

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

34−

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

3537

3638

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

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

33module ProjectM36.Base where

44import ProjectM36.DatabaseContextFunctionError

55import ProjectM36.AtomFunctionError

6+import ProjectM36.TupleFunctionError

78import qualified Data.Map as M

89import qualified Data.HashSet as HS

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

3536 ByteStringAtom ByteString |

3637 BoolAtom Bool |

3738 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

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

4042

43+type TupleFunctionName = StringType

44+

4145instance Hashable Atom where

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

4347 `hashWithSalt` dConsName --AtomType is not hashable

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

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

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

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

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

5257

5358instance Binary UTCTime where

5459 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)

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

7378 BoolAtomType |

7479 RelationAtomType Attributes |

7580 ConstructedAtomType TypeConstructorName TypeVarMap |

81+ TupleFunctionAtomType |

7682 TypeVariableType TypeVarName

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

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

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

273279 deriving (Generic, Binary, Show)

274280

275281type 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

276291

277292data DatabaseContext = DatabaseContext {

278293 inclusionDependencies :: InclusionDependencies,

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

280295 atomFunctions :: AtomFunctions,

281296 dbcFunctions :: DatabaseContextFunctions,

282297 notifications :: Notifications,

283− typeConstructorMapping :: TypeConstructorMapping

298+ typeConstructorMapping :: TypeConstructorMapping,

299+ tupleFunctions :: TupleFunctions

284300 } deriving (NFData, Generic)

285301

286302type IncDepName = StringType

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

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

3535atomTypeForAtom (BoolAtom _) = BoolAtomType

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

3737atomTypeForAtom (ConstructedAtom _ aType _) = aType

38+atomTypeForAtom (TupleFunctionAtom _) = TupleFunctionAtomType

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

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

1313 notifications = M.empty,

1414 atomFunctions = HS.empty,

1515 dbcFunctions = HS.empty,

16− typeConstructorMapping = [] }

16+ typeConstructorMapping = [],

17+ tupleFunctions = M.empty }

1718

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

1920databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

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

3132 atomFunctions = basicAtomFunctions,

3233 dbcFunctions = basicDatabaseContextFunctions,

3334 notifications = M.empty,

34− typeConstructorMapping = basicTypeConstructorMapping

35+ typeConstructorMapping = basicTypeConstructorMapping,

36+ tupleFunctions = M.empty

3537 }

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

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

66import ProjectM36.Base

77import ProjectM36.Error

88import ProjectM36.AtomType

9+import ProjectM36.TupleFunction

910import ProjectM36.Attribute (emptyAttributes)

1011import ProjectM36.ScriptSession

1112import ProjectM36.DataTypes.Primitive

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

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

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

672673 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+

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

675683typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

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

7272 typeConstructorMapping = typeCons,

7373 notifications = M.empty,

7474 atomFunctions = atomFuncs,

75− dbcFunctions = dbcFuncs }

75+ dbcFunctions = dbcFuncs,

76+ tupleFunctions = undefined}

7677 newSchemas = Schemas newContext sschemas

7778 return $ Right $ Transaction transId transInfo newSchemas

7879

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

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

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

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

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

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

429430 -- TODO: add merge of subschemas

430431 let newContext = DatabaseContext {

431432 inclusionDependencies = incDeps,

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

433434 atomFunctions = atomFuncs,

434435 dbcFunctions = undefined,

435436 notifications = notifs,

436− typeConstructorMapping = types

437+ typeConstructorMapping = types,

438+ tupleFunctions = tupleFuncs

437439 }

438440 newSchemas = Schemas newContext (subschemas t1)

439441 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

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

3+data TupleFunctionError = FunctionPooped