8c305bd · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP compilation checkpoint

library builds with so TODO warnings

commit8c305bda22350f97c10cfe9afbcd2d11d4ab65e4 authorAgentM <agentm@themactionfaction.com> dateTue 31 Dec 2019, 21:58 (7 years ago) parent1706097

14 files changed+293−76

compare with master

unifiedsplit

project-m36.cabal+5−1

@@ -102,7 +102,11 @@ Library

102102 ProjectM36.TypeConstructorDef,

103103 ProjectM36.FileLock,

104104 ProjectM36.FSType,

105− ProjectM36.Arbitrary

105+ ProjectM36.Arbitrary,

106+ ProjectM36.GraphRefRelationalExpr,

107+ ProjectM36.NormalizeExpr,

108+ ProjectM36.TransactionInfo,

109+ ProjectM36.WithNameExpr

106110 GHC-Options: -Wall -rdynamic

107111 if os(windows)

108112 Build-Depends: Win32 >= 2.5.4.1

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+2−1

@@ -186,13 +186,14 @@ executeDatabaseContextFunctionP = do

186186databaseExprOpP :: Parser DatabaseContextExpr

187187databaseExprOpP = multipleDatabaseContextExprP

188188

189+{-

189190evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext

190191evalDatabaseContextExpr useOptimizer context expr = do

191192 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context)

192193 case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of

193194 (Right (), (context',_, _)) -> Right context'

194195 (Left err, _) -> Left err

195−

196+-}

196197

197198interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext

198199interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of

src/bin/TutorialD/Interpreter/RelationalExpr.hs+6−5

@@ -238,13 +238,14 @@ relationAtomExprP = RelationAtomExpr <$> makeRelationP

238238withMacroExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

239239withMacroExprP = do

240240 reservedOp "with"

241− views <- parens (sepBy1 createViewP comma)

242− With views <$> relExprP

241+ macros <- parens (sepBy1 createMacroP comma)

242+ With macros <$> relExprP

243243

244−createViewP :: RelationalMarkerExpr a => Parser (RelVarName, RelationalExprBase a)

245−createViewP = do

244+createMacroP :: RelationalMarkerExpr a => Parser (WithNameExprBase a, RelationalExprBase a)

245+createMacroP = do

246246 name <- identifier

247247 reservedOp "as"

248248 expr <- relExprP

249− pure (name, expr)

249+ marker <- parseMarkerP

250+ pure (WithNameExpr name marker, expr)

250251

src/lib/ProjectM36/Base.hs+12−1

@@ -215,10 +215,21 @@ data RelationalExprBase a =

215215 Extend (ExtendTupleExprBase a) (RelationalExprBase a) |

216216 --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend

217217 --Evaluate relationalExpr with scoped views

218− With [(RelVarName,RelationalExprBase a)] (RelationalExprBase a)

218+ With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a)

219219 deriving (Show, Eq, Generic, NFData, Foldable, Functor)

220220

221221instance Binary RelationalExpr

222+

223+data WithNameExprBase a = WithNameExpr RelVarName a

224+ deriving (Show, Eq, Generic, NFData, Foldable, Functor)

225+

226+type WithNameExpr = WithNameExprBase ()

227+

228+instance Binary WithNameExpr

229+

230+type GraphRefWithNameExpr = WithNameExprBase TransactionId

231+

232+instance Binary GraphRefWithNameExpr

222233

223234type NotificationName = StringType

224235type Notifications = M.Map NotificationName Notification

src/lib/ProjectM36/Client.hs+7−7

@@ -114,7 +114,6 @@ import qualified ProjectM36.DataFrame as DF

114114import ProjectM36.DatabaseContextFunction as DCF

115115import qualified ProjectM36.IsomorphicSchema as Schema

116116import Control.Monad.State

117−import Control.Monad.Trans.Reader

118117import qualified ProjectM36.RelationalExpression as RE

119118import ProjectM36.DatabaseContext (basicDatabaseContext)

120119import qualified ProjectM36.TransactionGraph as Graph

@@ -125,6 +124,7 @@ import ProjectM36.Attribute

125124import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalExpr)

126125import ProjectM36.Persist (DiskSync(..))

127126import ProjectM36.FileLock

127+import ProjectM36.NormalizeExpr

128128import ProjectM36.Notifications

129129import ProjectM36.Server.RemoteCallTypes

130130import qualified ProjectM36.DisconnectedTransaction as Discon

@@ -599,7 +599,7 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither

599599 let ctx = Sess.concreteDatabaseContext session

600600 env = RE.mkDatabaseContextEvalEnv transId graph

601601 transId = Sess.parentId session

602− case RE.runDatabaseContextEvalMonad ctx env (optimizeAndEvalDatabaseContextExpr expr'') of

602+ case RE.runDatabaseContextEvalMonad ctx env (optimizeAndEvalDatabaseContextExpr True expr'') of

603603 Left err -> pure (Left err)

604604 Right newState ->

605605 if not (RE.dbc_dirty newState) then --nothing dirtied, nothing to do

@@ -877,9 +877,10 @@ typeForRelationalExprSTM sessionId (InProcessConnection conf) relExpr = do

877877 case processed of

878878 Left err -> pure (Left err)

879879 Right relExpr' -> do

880+ graph <- readTVar (ipTransactionGraph conf)

880881 let transId = Sess.parentId session

881− graph <- readTVar (ipTransactionGraph conf)

882− pure $ runReader (RE.typeForRelationalExpr relExpr') (RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) transId graph)

882+ reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) transId graph

883+ pure $ RE.runRelationalExprM reEnv (RE.typeForRelationalExpr relExpr')

883884

884885typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"

885886

@@ -922,9 +923,8 @@ planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do

922923 Left err -> pure $ Left err

923924 Right (session, _) ->

924925 if schemaName session == defaultSchemaName then do

925− let env = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) transId graph

926− transId = Sess.parentId session

927− gfExpr = runReader (RE.processDatabaseContextExpr dbExpr) env

926+ let transId = Sess.parentId session

927+ gfExpr = runProcessExprM transId graph (processDatabaseContextExpr dbExpr)

928928 pure $ runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

929929 else -- don't show any optimization because the current optimization infrastructure relies on access to the base context- this probably underscores the need for each schema to have its own DatabaseContext, even if it is generated on-the-fly-}

930930 pure (Left NonConcreteSchemaPlanError)

src/lib/ProjectM36/DatabaseContextFunctionUtils.hs+1−1

@@ -12,7 +12,7 @@ executeDatabaseContextExpr expr transId graph context' =

1212 Left err -> error (show err)

1313 where

1414 env = mkDatabaseContextEvalEnv transId graph

15− run = runDatabaseContextEvalMonad context' env (optimizeAndEvalDatabaseContextExpr expr)

15+ run = runDatabaseContextEvalMonad context' env (optimizeAndEvalDatabaseContextExpr True expr)

1616

1717executeRelationalExpr :: RelationalExpr -> DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError Relation

1818executeRelationalExpr expr context transId graph =

src/lib/ProjectM36/IsomorphicSchema.hs−1

@@ -13,7 +13,6 @@ import Data.Binary

1313import qualified Data.Map as M

1414import qualified Data.Set as S

1515import qualified Data.List as L

16−import Control.Monad.Reader

1716#if __GLASGOW_HASKELL__ <= 802

1817import Data.Monoid

1918#endif

src/lib/ProjectM36/NormalizeExpr.hs+16−10

@@ -37,7 +37,7 @@ processRelationalExpr (Rename attrA attrB expr) =

3737processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB

3838processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr

3939processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr

40−processRelationalExpr (Restrict pred expr) = Restrict <$> processRestrictionPredicateExpr pred <*> processRelationalExpr expr

40+processRelationalExpr (Restrict pred' expr) = Restrict <$> processRestrictionPredicateExpr pred' <*> processRelationalExpr expr

4141processRelationalExpr (Equals exprA exprB) =

4242 Equals <$> processRelationalExpr exprA <*> processRelationalExpr exprB

4343processRelationalExpr (NotEquals exprA exprB) =

@@ -45,10 +45,16 @@ processRelationalExpr (NotEquals exprA exprB) =

4545processRelationalExpr (Extend extendExpr expr) =

4646 Extend <$> processExtendTupleExpr extendExpr <*> processRelationalExpr expr

4747processRelationalExpr (With macros expr) =

48− With <$> mapM (\(nam, wexpr) -> (,) nam <$> processRelationalExpr wexpr) macros <*> processRelationalExpr expr

48+ With <$> mapM (\(wnexpr, macroExpr) -> (,) <$> processWithNameExpr wnexpr <*> processRelationalExpr macroExpr) macros <*> processRelationalExpr expr

49+

50+processWithNameExpr :: WithNameExpr -> ProcessExprM GraphRefWithNameExpr

51+processWithNameExpr (WithNameExpr rvname ()) =

52+ WithNameExpr rvname <$> askTid

4953

5054processAttributeNames :: AttributeNames -> ProcessExprM GraphRefAttributeNames

5155processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet

56+processAttributeNames (InvertedAttributeNames attrNameSet) =

57+ pure $ InvertedAttributeNames attrNameSet

5258processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

5359processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

5460processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr

@@ -61,8 +67,8 @@ processDatabaseContextExpr expr =

6167 Undefine nam -> pure (Undefine nam)

6268 Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr

6369 Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr

64− Delete nam pred -> Delete nam <$> processRestrictionPredicateExpr pred

65− Update nam attrMap pred -> Update nam attrMap <$> processRestrictionPredicateExpr pred

70+ Delete nam pred' -> Delete nam <$> processRestrictionPredicateExpr pred'

71+ Update nam attrMap pred' -> Update nam attrMap <$> processRestrictionPredicateExpr pred'

6672

6773 AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)

6874 RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)

@@ -79,12 +85,12 @@ processDatabaseContextExpr expr =

7985processDatabaseContextIOExpr :: DatabaseContextIOExpr -> ProcessExprM GraphRefDatabaseContextIOExpr

8086processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =

8187 pure (AddAtomFunction f tcs sc)

82−processDatabaseContextIOExpr (LoadAtomFunctions mod fun file) =

83− pure (LoadAtomFunctions mod fun file)

84−processDatabaseContextIOExpr (AddDatabaseContextFunction mod fun path) =

85− pure (AddDatabaseContextFunction mod fun path)

86−processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod fun path) =

87− pure (LoadDatabaseContextFunctions mod fun path)

88+processDatabaseContextIOExpr (LoadAtomFunctions mod' fun file) =

89+ pure (LoadAtomFunctions mod' fun file)

90+processDatabaseContextIOExpr (AddDatabaseContextFunction mod' fun path) =

91+ pure (AddDatabaseContextFunction mod' fun path)

92+processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod' fun path) =

93+ pure (LoadDatabaseContextFunctions mod' fun path)

8894processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =

8995 CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range

9096

src/lib/ProjectM36/Relation.hs+1−1

@@ -95,7 +95,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

9595 where

9696 newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2)

9797

98−project :: S.Set AttributeName -> Relation -> Either RelationalError Relation

98+project :: S.Set AttributeName -> Relation -> Either RelationalError Relation

9999project attrNames rel@(Relation _ tupSet) = do

100100 newAttrs <- A.projectionAttributesForNames attrNames (attributes rel)

101101 let newAttrNameSet = A.attributeNameSet newAttrs

src/lib/ProjectM36/RelationalExpression.hs+140−39

@@ -18,7 +18,7 @@ import qualified ProjectM36.Attribute as A

1818import qualified Data.Map as M

1919import qualified Data.HashSet as HS

2020import qualified Data.Set as S

21−import Control.Monad.RWS.Strict as RWS

21+import Control.Monad.RWS.Strict as RWS hiding (join)

2222import Control.Monad.Trans.Class (lift)

2323import Control.Exception

2424import Data.Maybe

@@ -27,10 +27,11 @@ import Data.Char (isUpper)

2727import qualified Data.Text as T

2828import qualified Data.Vector as V

2929import qualified ProjectM36.TypeConstructorDef as TCD

30−import Control.Monad.Except

30+import Control.Monad.Except hiding (join)

3131import Control.Monad.Trans.Except (except)

32−import Control.Monad.Reader as R

32+import Control.Monad.Reader as R hiding (join)

3333import ProjectM36.NormalizeExpr

34+import ProjectM36.WithNameExpr

3435import Test.QuickCheck

3536import GHC

3637import GHC.Paths

@@ -38,11 +39,6 @@ import Data.Time.Clock

3839import Data.Time.Calendar

3940import qualified Data.List.NonEmpty as NE

4041import Data.Functor.Identity

41−import Control.Monad

42−import Control.Monad.IO.Class

43−#if __GLASGOW_HASKELL__ <= 802

44−import Data.Monoid

45−#endif

4642

4743data DatabaseContextExprDetails = CountUpdatedTuples

4844

@@ -86,14 +82,12 @@ instance Show RelationalExprEnv where

8682--used to eval relationalexpr

8783type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a

8884

85+runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either RelationalError a

86+runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

87+

8988reGraph :: RelationalExprM TransactionGraph

9089reGraph = re_graph <$> R.ask

9190

92−gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction

93−gfTransForId tid = do

94− graph <- gfGraph

95− lift $ except $ transactionForId tid graph

96−

9791currentTrans :: RelationalExprM Transaction

9892currentTrans = do

9993 tid <- re_currentTransId <$> R.ask

@@ -183,6 +177,11 @@ data GraphRefRelationalExprEnv =

183177

184178type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a

185179

180+gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction

181+gfTransForId tid = do

182+ graph <- gfGraph

183+ lift $ except $ transactionForId tid graph

184+

186185runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a

187186runGraphRefRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

188187

@@ -388,7 +387,6 @@ evalGraphRefDatabaseContextExpr NoOperation = pure ()

388387evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do

389388 relvars <- fmap relationVariables getStateContext

390389 tConss <- fmap typeConstructorMapping getStateContext

391− relEnv <- dbcRelationalExprEnv

392390 graph <- dbcGraph

393391 let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)

394392 gfEnv = freshGraphRefRelationalExprEnv graph

@@ -456,7 +454,7 @@ evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

456454 tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict

457455 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

458456 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

459− restrictedPortion = Restrict pred'

457+ --TODO restrictedPortion = Restrict pred'

460458 updated = foldr (\(oldname, atomExpr) accum ->

461459 let procAtomExpr = runProcessExprM transId graph (processAtomExpr atomExpr) in

462460 updateAttr oldname procAtomExpr accum

@@ -572,7 +570,6 @@ evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do

572570

573571evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

574572 context <- getStateContext

575− relExprEnv <- dbcRelationalExprEnv

576573 graph <- dbcGraph

577574 --resolve atom arguments

578575 let eAtomTypes = mapM (\atomExpr -> runGraphRefRelationalExprM gfEnv (typeForGraphRefAtomExpr emptyAttributes atomExpr)) atomArgExprs

@@ -744,7 +741,6 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

744741 --create graph ref expr

745742 let gfExpr = Define relVarName attrExprs

746743 evalEnv = mkDatabaseContextEvalEnv (dbcio_transId env) (dbcio_graph env)

747− transId = dbcio_transId env

748744 graph = dbcio_graph env

749745 case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of

750746 Left err -> pure (Left err)

@@ -755,8 +751,8 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

755751 case existingRelVar of

756752 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

757753 Just existingRel -> do

758− let env = freshGraphRefRelationalExprEnv graph

759− case runGraphRefRelationalExprM env (typeForGraphRefRelationalExpr existingRel) of

754+ let gfEnv = freshGraphRefRelationalExprEnv graph

755+ case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of

760756 Left err -> pure (Left err)

761757 Right relType -> do

762758 let expectedAttributes = attributes relType

@@ -793,7 +789,6 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

793789 tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas

794790

795791 deps = inclusionDependencies context

796− reEnv = mkRelationalExprEnv context transId graph

797792 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment

798793 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

799794 let process = runProcessExprM transId graph

@@ -806,8 +801,8 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

806801 typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)

807802 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))

808803 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

809− gfEvald = runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr checkExpr)

810− gfEnv = freshGraphRefRelationalExprEnv potentialGraph

804+ gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)

805+ gfEnv' = freshGraphRefRelationalExprEnv potentialGraph

811806 case gfEvald of

812807 Left err -> Left err

813808 Right resultRel -> if resultRel == relationTrue then

@@ -930,7 +925,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName r

930925

931926extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)

932927extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do

933− renv <- askEnv

928+-- renv <- askEnv

934929 -- check that the attribute name is not in use

935930 case tupleExprCheckNewAttrName newAttrName relIn of

936931 Left err -> throwError err

@@ -939,7 +934,8 @@ extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrNa

939934 atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType

940935 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']

941936 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

942− pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in

937+ pure (newAndOldAttrs, \tup ->

938+ --let substate = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in

943939 case unimplemented {-runReader (evalAtomExpr tup atomExpr) substate-} of

944940 Left err -> Left err

945941 Right atom -> Right (tupleAtomExtend newAttrName atom tup)

@@ -1011,6 +1007,7 @@ typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

10111007 Left _ -> case atomForAttributeName attrName envTup of

10121008 Right atom -> pure (atomTypeForAtom atom)

10131009 Left _ -> throwError err

1010+ Left err -> throwError err

10141011

10151012typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)

10161013typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do

@@ -1049,6 +1046,8 @@ verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do

10491046 case A.attributeForName attrName attrs' of

10501047 Left err' -> throwError err'

10511048 Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)

1049+ Left err -> throwError err

1050+

10521051verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =

10531052 lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)

10541053verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) expectedType = do

@@ -1165,14 +1164,72 @@ evalAttributeNames attrNames expr = do

11651164 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

11661165-}

11671166

1167+--temporary implementation until we have a proper planner+executor

11681168evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1169−--evalGraphRefRelationalExpr (MakeRelationaFromExprs

1169+evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1170+ mAttrs <- case mAttrExprs of

1171+ Just _ ->

1172+ Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)

1173+ Nothing -> pure Nothing

1174+ tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprs

1175+ let attrs = fromMaybe firstTupleAttrs mAttrs

1176+ firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

1177+ lift $ except $ mkRelation attrs (RelationTupleSet tuples)

1178+evalGraphRefRelationalExpr (MakeStaticRelation attributeSet tupleSet) =

1179+ lift $ except $ mkRelation attributeSet tupleSet

1180+evalGraphRefRelationalExpr (ExistingRelation rel) = pure rel

11701181evalGraphRefRelationalExpr (RelationVariable name tid) = do

11711182 ctx <- concreteDatabaseContext <$> gfTransForId tid

11721183 case M.lookup name (relationVariables ctx) of

11731184 Nothing -> throwError (RelVarNotDefinedError name)

11741185 Just rv -> evalGraphRefRelationalExpr rv

1175−

1186+evalGraphRefRelationalExpr (Project attrNames expr) = do

1187+ attrNameSet <- evalGraphRefAttributeNames attrNames expr

1188+ rel <- evalGraphRefRelationalExpr expr

1189+ lift $ except $ project attrNameSet rel

1190+evalGraphRefRelationalExpr (Union exprA exprB) = do

1191+ relA <- evalGraphRefRelationalExpr exprA

1192+ relB <- evalGraphRefRelationalExpr exprB

1193+ lift $ except $ union relA relB

1194+evalGraphRefRelationalExpr (Join exprA exprB) = do

1195+ relA <- evalGraphRefRelationalExpr exprA

1196+ relB <- evalGraphRefRelationalExpr exprB

1197+ lift $ except $ join relA relB

1198+evalGraphRefRelationalExpr (Rename oldName newName expr) = do

1199+ rel <- evalGraphRefRelationalExpr expr

1200+ lift $ except $ rename oldName newName rel

1201+evalGraphRefRelationalExpr (Difference exprA exprB) = do

1202+ relA <- evalGraphRefRelationalExpr exprA

1203+ relB <- evalGraphRefRelationalExpr exprB

1204+ lift $ except $ difference relA relB

1205+evalGraphRefRelationalExpr (Group groupAttrNames newAttrName expr) = do

1206+ groupNames <- evalGraphRefAttributeNames groupAttrNames expr

1207+ rel <- evalGraphRefRelationalExpr expr

1208+ lift $ except $ group groupNames newAttrName rel

1209+evalGraphRefRelationalExpr (Ungroup groupAttrName expr) = do

1210+ rel <- evalGraphRefRelationalExpr expr

1211+ lift $ except $ ungroup groupAttrName rel

1212+evalGraphRefRelationalExpr (Restrict predExpr expr) = do

1213+ rel <- evalGraphRefRelationalExpr expr

1214+ filt <- predicateRestrictionFilter (attributes rel) predExpr

1215+ lift $ except $ restrict filt rel

1216+evalGraphRefRelationalExpr (Equals exprA exprB) = do

1217+ relA <- evalGraphRefRelationalExpr exprA

1218+ relB <- evalGraphRefRelationalExpr exprB

1219+ pure $ if relA == relB then relationTrue else relationFalse

1220+evalGraphRefRelationalExpr (NotEquals exprA exprB) = do

1221+ relA <- evalGraphRefRelationalExpr exprA

1222+ relB <- evalGraphRefRelationalExpr exprB

1223+ pure $ if relA == relB then relationFalse else relationTrue

1224+evalGraphRefRelationalExpr (Extend extendTupleExpr expr) = do

1225+ rel <- evalGraphRefRelationalExpr expr

1226+ (newAttrs, tupProc) <- extendGraphRefTupleExpressionProcessor rel extendTupleExpr

1227+ lift $ except $ relMogrify tupProc newAttrs rel

1228+evalGraphRefRelationalExpr expr@With{} = do

1229+ --strategy A: add relation variables to the contexts in the graph

1230+ --strategy B: drop in macros in place (easier programmatically)

1231+ --strategy B implementation

1232+ evalGraphRefRelationalExpr (substituteWithNameMacros [] expr)

11761233

11771234dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext

11781235dbContextForTransId tid graph = do

@@ -1193,28 +1250,71 @@ transactionForId tid graph

11931250typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

11941251typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet

11951252typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))

1196−typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =

1197− case mAttrExprs of

1198− Just attrExprs -> do

1199− attrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs

1200− pure (emptyRelationWithAttrs (attributesFromList attrs))

1253+typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1254+ mAttrs <- case mAttrExprs of

1255+ Just attrExprs -> do

1256+ attrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs

1257+ pure (Just (attributesFromList attrs))

1258+ Nothing -> pure Nothing

1259+ tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprs

1260+ let retAttrs = case tuples of

1261+ (tup:_) -> tupleAttributes tup

1262+ [] -> fromMaybe A.emptyAttributes mAttrs

1263+ pure $ emptyRelationWithAttrs retAttrs

1264+

12011265typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

12021266 relVars <- relationVariables . concreteDatabaseContext <$> gfTransForId tid

12031267 case M.lookup rvName relVars of

12041268 Nothing -> throwError (RelVarNotDefinedError rvName)

12051269 Just rvExpr -> typeForGraphRefRelationalExpr rvExpr

12061270typeForGraphRefRelationalExpr (Project attrNames expr) = do

1207− exprType <- typeForGraphRefRelationalExpr expr

1271+ exprType' <- typeForGraphRefRelationalExpr expr

12081272 projectionAttrs <- evalGraphRefAttributeNames attrNames expr

1209− lift $ except $ project projectionAttrs exprType

1210−

1273+ lift $ except $ project projectionAttrs exprType'

1274+typeForGraphRefRelationalExpr (Union exprA exprB) = do

1275+ exprA' <- typeForGraphRefRelationalExpr exprA

1276+ exprB' <- typeForGraphRefRelationalExpr exprB

1277+ lift $ except $ union exprA' exprB'

1278+typeForGraphRefRelationalExpr (Join exprA exprB) = do

1279+ exprA' <- typeForGraphRefRelationalExpr exprA

1280+ exprB' <- typeForGraphRefRelationalExpr exprB

1281+ lift $ except $ join exprA' exprB'

1282+typeForGraphRefRelationalExpr (Rename oldAttr newAttr expr) = do

1283+ expr' <- typeForGraphRefRelationalExpr expr

1284+ lift $ except $ rename oldAttr newAttr expr'

1285+typeForGraphRefRelationalExpr (Difference exprA exprB) = do

1286+ exprA' <- typeForGraphRefRelationalExpr exprA

1287+ exprB' <- typeForGraphRefRelationalExpr exprB

1288+ lift $ except $ difference exprA' exprB'

1289+typeForGraphRefRelationalExpr (Group groupNames attrName expr) = do

1290+ expr' <- typeForGraphRefRelationalExpr expr

1291+ groupNames' <- evalGraphRefAttributeNames groupNames expr

1292+ lift $ except $ group groupNames' attrName expr'

1293+typeForGraphRefRelationalExpr (Ungroup groupAttrName expr) = do

1294+ expr' <- typeForGraphRefRelationalExpr expr

1295+ lift $ except $ ungroup groupAttrName expr'

1296+typeForGraphRefRelationalExpr (Restrict pred' expr) = do

1297+ expr' <- typeForGraphRefRelationalExpr expr

1298+ filt <- predicateRestrictionFilter (attributes expr') pred'

1299+ lift $ except $ restrict filt expr'

1300+typeForGraphRefRelationalExpr Equals{} = do

1301+ pure relationFalse

1302+typeForGraphRefRelationalExpr NotEquals{} = do

1303+ pure relationFalse

1304+typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do

1305+ rel <- typeForGraphRefRelationalExpr expr

1306+ evalGraphRefRelationalExpr (Extend extendTupleExpr (ExistingRelation rel))

1307+typeForGraphRefRelationalExpr expr@With{} = do

1308+ let expr' = substituteWithNameMacros [] expr

1309+ typeForGraphRefRelationalExpr expr'

1310+

12111311evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)

12121312evalGraphRefAttributeNames attrNames expr = do

1213− exprType <- typeForGraphRefRelationalExpr expr

1214− let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType)))

1313+ exprType' <- typeForGraphRefRelationalExpr expr

1314+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType')))

12151315 case attrNames of

12161316 AttributeNames names ->

1217− case A.projectionAttributesForNames names (attributes exprType) of

1317+ case A.projectionAttributesForNames names (attributes exprType') of

12181318 Left err -> throwError err

12191319 Right attrs -> pure (S.fromList (V.toList (A.attributeNames attrs)))

12201320

@@ -1248,6 +1348,7 @@ evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

12481348 case validateAtomType aType tConsMap of

12491349 Left err -> throwError err

12501350 Right _ -> pure (Attribute attrName aType)

1351+evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr

12511352

12521353mkEmptyRelVars :: RelationVariables -> RelationVariables

12531354mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

@@ -1263,11 +1364,11 @@ mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

12631364 mkEmptyRelVar (Difference exprA exprB) = Difference (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

12641365 mkEmptyRelVar (Group attrNames attrName expr) = Group attrNames attrName (mkEmptyRelVar expr)

12651366 mkEmptyRelVar (Ungroup attrName expr) = Ungroup attrName (mkEmptyRelVar expr)

1266− mkEmptyRelVar (Restrict pred expr) = Restrict pred (mkEmptyRelVar expr)

1367+ mkEmptyRelVar (Restrict pred' expr) = Restrict pred' (mkEmptyRelVar expr)

12671368 mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

12681369 mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

12691370 mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)

1270− mkEmptyRelVar (With macros expr) = With (map (\(rv, expr) -> (rv, mkEmptyRelVar expr)) macros) (mkEmptyRelVar expr)

1371+ mkEmptyRelVar (With macros expr) = With (map (\(rv, expr') -> (rv, mkEmptyRelVar expr')) macros) (mkEmptyRelVar expr)

12711372

12721373

12731374dbErr :: RelationalError -> DatabaseContextEvalMonad ()

src/lib/ProjectM36/StaticOptimizer.hs+6−4

@@ -35,12 +35,15 @@ optimizeAndEvalRelationalExpr env expr = do

3535 optExpr <- runGraphRefStaticOptimizerMonad (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)

3636 runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

3737

38−optimizeAndEvalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextEvalMonad ()

39−optimizeAndEvalDatabaseContextExpr expr = do

38+optimizeAndEvalDatabaseContextExpr :: Bool -> DatabaseContextExpr -> DatabaseContextEvalMonad ()

39+optimizeAndEvalDatabaseContextExpr optimize expr = do

4040 tid <- dce_transId <$> ask

4141 graph <- dce_graph <$> ask

4242 let gfExpr = runProcessExprM tid graph (processDatabaseContextExpr expr)

43− eOptExpr = runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

43+ eOptExpr = if optimize then

44+ runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

45+ else

46+ pure gfExpr

4447 case eOptExpr of

4548 Left err -> throwError err

4649 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

@@ -363,7 +366,6 @@ applyStaticJoinElimination expr@(Project attrNameSet (Join exprA exprB)) = do

363366 gfSubRv = processM (processRelationalExpr subrv)

364367 gfSuperRv = processM (processRelationalExpr superrv)

365368 processM = runProcessExprM commonTransId graph

366− gfEnv = freshGraphRefRelationalExprEnv graph

367369 case runGraphRefRelationalExprM gfEnv (evalGraphRefAttributeNames gfSubAttrNames expr) of

368370 Left _ -> pure acc

369371 Right subAttrNameSet ->

src/lib/ProjectM36/TransGraphRelationalExpression.hs+11−2

@@ -39,6 +39,10 @@ instance Binary TransGraphAtomExpr

3939

4040type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

4141

42+type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup

43+

44+instance Binary TransGraphWithNameExpr

45+

4246data TransGraphEvalEnv = TransGraphEvalEnv {

4347 tge_graph :: TransactionGraph

4448 }

@@ -108,9 +112,10 @@ processTransGraphRelationalExpr (Extend extendExpr expr) = do

108112 expr' <- processTransGraphRelationalExpr expr

109113 pure (Extend extendExpr' expr')

110114processTransGraphRelationalExpr (With views expr) = do

111− evaldViews <- mapM (\(vname, vexpr) -> do

115+ evaldViews <- mapM (\(wnexpr, vexpr) -> do

116+ wnexpr' <- processTransGraphWithNameExpr wnexpr

112117 vexpr' <- processTransGraphRelationalExpr vexpr

113− pure (vname, vexpr')

118+ pure (wnexpr', vexpr')

114119 ) views

115120 expr' <- processTransGraphRelationalExpr expr

116121 pure (With evaldViews expr')

@@ -178,3 +183,7 @@ processTransGraphAttributeNames (IntersectAttributeNames namesA namesB) = do

178183processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do

179184 evaldExpr <- processTransGraphRelationalExpr expr

180185 pure (RelationalExprAttributeNames evaldExpr)

186+

187+processTransGraphWithNameExpr :: TransGraphWithNameExpr -> TransGraphEvalMonad GraphRefWithNameExpr

188+processTransGraphWithNameExpr (WithNameExpr rvname tlookup) =

189+ WithNameExpr rvname <$> findTransId tlookup

src/lib/ProjectM36/TransactionInfo.hs+2−3

@@ -1,11 +1,10 @@

11module ProjectM36.TransactionInfo where

22import ProjectM36.Base

3−import qualified Data.Set as S

43import Data.Time.Clock

54import Data.List.NonEmpty

76-- | Create a TransactionInfo with just one parent transaction ID.

87singleParent :: TransactionId -> UTCTime -> TransactionInfo

9−singleParent tid stamp = TransactionInfo {

8+singleParent tid stamp' = TransactionInfo {

109 parents = tid :| [],

11− stamp = stamp }

10+ stamp = stamp' }

src/lib/ProjectM36/WithNameExpr.hsnew file+84

@@ -0,0 +1,84 @@

1+module ProjectM36.WithNameExpr where

2+import ProjectM36.Base

4+-- substitute all instances of With-based macros to remove macro context

5+-- ideally, we would use a different relational expr type to "prove" that the with macros can no longer exist

6+type WithNameAssocs = [(GraphRefWithNameExpr, GraphRefRelationalExpr)]

7+-- | Drop macros into the relational expression wherever they are referenced.

8+substituteWithNameMacros ::

9+ WithNameAssocs ->

10+ GraphRefRelationalExpr ->

11+ GraphRefRelationalExpr

12+substituteWithNameMacros _ e@MakeRelationFromExprs{} = e

13+substituteWithNameMacros _ e@MakeStaticRelation{} = e

14+substituteWithNameMacros _ e@ExistingRelation{} = e

15+substituteWithNameMacros macros e@(RelationVariable rvname tid) =

16+ let

17+ macroFilt (WithNameExpr macroName macroTid, _) = rvname == macroName && tid== macroTid in

18+ case filter macroFilt macros of

19+ [] -> e

20+ (_,replacement):[] -> replacement

21+ _ -> error "more than one macro matched!"

22+substituteWithNameMacros macros (Project attrs expr) =

23+ Project attrs (substituteWithNameMacros macros expr)

24+substituteWithNameMacros macros (Union exprA exprB) =

25+ Union (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

26+substituteWithNameMacros macros (Join exprA exprB) =

27+ Join (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

28+substituteWithNameMacros macros (Rename attrA attrB expr) =

29+ Rename attrA attrB (substituteWithNameMacros macros expr)

30+substituteWithNameMacros macros (Difference exprA exprB) =

31+ Difference (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

32+substituteWithNameMacros macros (Group attrs attr expr) =

33+ Group attrs attr (substituteWithNameMacros macros expr)

34+substituteWithNameMacros macros (Ungroup attr expr) =

35+ Ungroup attr (substituteWithNameMacros macros expr)

36+substituteWithNameMacros macros (Restrict pred' expr) =

37+ Restrict (substituteWithNameMacrosRestrictionPredicate macros pred') (substituteWithNameMacros macros expr)

38+substituteWithNameMacros macros (Equals exprA exprB) =

39+ Equals (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

40+substituteWithNameMacros macros (NotEquals exprA exprB) =

41+ NotEquals (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

42+substituteWithNameMacros macros (Extend extendTup expr) =

43+ Extend (substituteWitNameMacrosExtendTupleExpr macros extendTup) (substituteWithNameMacros macros expr)

44+substituteWithNameMacros macros (With moreMacros expr) =

45+ --collect and override existing macros and recurse

46+ let newMacros = foldr macroFolder macros moreMacros

47+ macroFolder (wnexpr, mexpr) acc = filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, mexpr)] in

48+ --scan for a match- if it exists, replace it (representing a with clause at a lower level

49+ substituteWithNameMacros newMacros expr

50+

51+

52+substituteWithNameMacrosRestrictionPredicate :: WithNameAssocs -> GraphRefRestrictionPredicateExpr -> GraphRefRestrictionPredicateExpr

53+substituteWithNameMacrosRestrictionPredicate macros pred' =

54+ let sub = substituteWithNameMacrosRestrictionPredicate macros in

55+ case pred' of

56+ TruePredicate -> pred'

57+ AndPredicate exprA exprB ->

58+ AndPredicate (sub exprA) (sub exprB)

59+ OrPredicate exprA exprB ->

60+ OrPredicate (sub exprA) (sub exprB)

61+ NotPredicate expr ->

62+ NotPredicate (sub expr)

63+ RelationalExprPredicate reexpr ->

64+ RelationalExprPredicate (substituteWithNameMacros macros reexpr)

65+ AtomExprPredicate atomExpr ->

66+ AtomExprPredicate (substituteWithNameMacrosAtomExpr macros atomExpr)

67+ AttributeEqualityPredicate attrName atomExpr ->

68+ AttributeEqualityPredicate attrName (substituteWithNameMacrosAtomExpr macros atomExpr)

69+

70+substituteWitNameMacrosExtendTupleExpr :: WithNameAssocs -> GraphRefExtendTupleExpr -> GraphRefExtendTupleExpr

71+substituteWitNameMacrosExtendTupleExpr macros (AttributeExtendTupleExpr attrName atomExpr) =

72+ AttributeExtendTupleExpr attrName (substituteWithNameMacrosAtomExpr macros atomExpr)

73+

74+substituteWithNameMacrosAtomExpr :: WithNameAssocs -> GraphRefAtomExpr -> GraphRefAtomExpr

75+substituteWithNameMacrosAtomExpr macros atomExpr =

76+ case atomExpr of

77+ e@AttributeAtomExpr{} -> e

78+ e@NakedAtomExpr{} -> e

79+ FunctionAtomExpr fname atomExprs tid ->

80+ FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid

81+ RelationAtomExpr reExpr ->

82+ RelationAtomExpr (substituteWithNameMacros macros reExpr)

83+ ConstructedAtomExpr dconsName atomExprs tid ->

84+ ConstructedAtomExpr dconsName (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid