01340e6 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

implement hlint suggestions

01340e6AgentM6 years ago

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

compare with master

unifiedsplit

@@ -206,8 +206,7 @@ interpretDatabaseContextExpr context transId graph tutdstring =

206 Left err -> Left $ PM36E.ParseError (T.pack (show err))

207 Right parsed -> do

208 let env = RE.mkDatabaseContextEvalEnv transId graph

209− x <- RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed)

209+ RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed)

210− pure x

211

210

212{-

211{-

213--no optimization

212--no optimization

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

@@ -320,7 +320,7 @@ validateAtomType _ _ = pure ()

320

321validateAttributes :: TypeConstructorMapping -> Attributes -> Either RelationalError ()

322validateAttributes tConss attrs =

323− if length errs > 0 then

323+ if not (null errs) then

324 Left (someErrors errs)

325 else

326 pure ()

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

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveFoldable, DeriveFunctor, DeriveTraversable #-}

1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable #-}

2{-# OPTIONS_GHC -fno-warn-orphans #-}

4module ProjectM36.Base where

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

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, BangPatterns, MonoLocalBinds #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, MonoLocalBinds #-}

2{-|

3Module: ProjectM36.Client

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

@@ -1,5 +1,6 @@

1module ProjectM36.DatabaseContext where

2import ProjectM36.Base

3+import Control.Monad (void)

3import qualified Data.Map as M

4import qualified Data.Map as M

4import qualified Data.HashSet as HS

5import qualified Data.HashSet as HS

5import ProjectM36.DataTypes.Basic

6import ProjectM36.DataTypes.Basic

@@ -17,7 +18,7 @@ empty = DatabaseContext { inclusionDependencies = M.empty,

18-- | Remove TransactionId markers on GraphRefRelationalExpr

19-- | Remove TransactionId markers on GraphRefRelationalExpr

19stripGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExpr

20stripGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExpr

20−stripGraphRefRelationalExpr = fmap (const ())

21+stripGraphRefRelationalExpr = void

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

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

23databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

24databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

src/lib/ProjectM36/GraphRefRelationalExpr.hs+6−9

@@ -26,15 +26,12 @@ instance Monoid SingularTransactionRef where

27-- | return `Just transid` if this GraphRefRelationalExpr refers to just one transaction in the graph. This is useful for determining if certain optimizations can apply.

28singularTransaction :: Foldable t => t GraphRefTransactionMarker -> SingularTransactionRef

29−singularTransaction expr =

29+singularTransaction expr

30− if S.null transSet then

31− NoTransactionsRef

30+ | S.null transSet = NoTransactionsRef

32− else if S.size transSet == 1 then

33− SingularTransactionRef (head (S.toList transSet))

31+ | S.size transSet == 1 = SingularTransactionRef (head (S.toList transSet))

34− else

35− MultipleTransactionsRef

32+ | otherwise = MultipleTransactionsRef

36 where

33 where

37− transSet = foldr (\transId acc -> S.insert transId acc) S.empty expr

34+ transSet = foldr S.insert S.empty expr

39-- | Return True if two 'GraphRefRelationalExpr's both refer exclusively to the same transaction (or none at all).

36-- | Return True if two 'GraphRefRelationalExpr's both refer exclusively to the same transaction (or none at all).

40inSameTransaction :: GraphRefRelationalExpr -> GraphRefRelationalExpr -> Maybe GraphRefTransactionMarker

37inSameTransaction :: GraphRefRelationalExpr -> GraphRefRelationalExpr -> Maybe GraphRefTransactionMarker

@@ -45,4 +42,4 @@ inSameTransaction exprA exprB = case (stA, stB) of

45 stB = singularTransaction exprB

42 stB = singularTransaction exprB

47singularTransactions :: (Foldable f, Foldable t) => f (t GraphRefTransactionMarker) -> SingularTransactionRef

44singularTransactions :: (Foldable f, Foldable t) => f (t GraphRefTransactionMarker) -> SingularTransactionRef

48−singularTransactions fs = foldMap singularTransaction fs

45+singularTransactions = foldMap singularTransaction

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

@@ -121,7 +121,7 @@ processTupleExprs (TupleExprs () tupleExprs) = do

121 TupleExprs marker <$> mapM processTupleExpr tupleExprs

122

123processTupleExpr :: TupleExpr -> ProcessExprM GraphRefTupleExpr

124−processTupleExpr (TupleExpr tMap) = do

124+processTupleExpr (TupleExpr tMap) =

125 TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)

126

127--convert AttributeExpr to GraphRefAttributeExpr

src/lib/ProjectM36/RelationalExpression.hs+30−28

@@ -22,6 +22,7 @@ import qualified Data.Map as M

22import qualified Data.HashSet as HS

23import qualified Data.Set as S

24import Control.Monad.State hiding (join)

25+import Data.Bifunctor (second)

25import Data.Maybe

26import Data.Maybe

26import Data.Either

27import Data.Either

27import Data.Char (isUpper)

28import Data.Char (isUpper)

@@ -90,10 +91,10 @@ runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either Relationa

90runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

91runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

92reGraph :: RelationalExprM TransactionGraph

93reGraph :: RelationalExprM TransactionGraph

93−reGraph = re_graph <$> R.ask

94+reGraph = asks re_graph

95reContext :: RelationalExprM DatabaseContext

96reContext :: RelationalExprM DatabaseContext

96−reContext = re_context <$> R.ask

97+reContext = asks re_context

98mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv

99mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv

99mkRelationalExprEnv ctx graph =

100mkRelationalExprEnv ctx graph =

@@ -138,12 +139,12 @@ data DatabaseContextEvalEnv = DatabaseContextEvalEnv

138 }

139 }

139

140

140mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv

141mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv

141−mkDatabaseContextEvalEnv tid graph = DatabaseContextEvalEnv tid graph

142+mkDatabaseContextEvalEnv = DatabaseContextEvalEnv

142

143

143type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a

144type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a

144

145

145runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState

146runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState

146−runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> (execRWST m env freshEnv)))

147+runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> execRWST m env freshEnv))

147 where

148 where

148 freshEnv = mkDatabaseContextEvalState ctx

149 freshEnv = mkDatabaseContextEvalState ctx

149

150

@@ -159,7 +160,7 @@ dbcRelationalExprEnv =

159 mkRelationalExprEnv <$> getStateContext <*> dbcGraph

160 mkRelationalExprEnv <$> getStateContext <*> dbcGraph

160

161

161getStateContext :: DatabaseContextEvalMonad DatabaseContext

162getStateContext :: DatabaseContextEvalMonad DatabaseContext

162−getStateContext = dbc_context <$> get

163+getStateContext = gets dbc_context

163

164

164putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()

165putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()

165putStateContext ctx' = do

166putStateContext ctx' = do

@@ -200,7 +201,7 @@ freshGraphRefRelationalExprEnv mctx graph = GraphRefRelationalExprEnv {

200 }

201 }

201

202

202gfGraph :: GraphRefRelationalExprM TransactionGraph

203gfGraph :: GraphRefRelationalExprM TransactionGraph

203−gfGraph = gre_graph <$> R.ask

204+gfGraph = asks gre_graph

204

205

205envContext :: RelationalExprEnv -> DatabaseContext

206envContext :: RelationalExprEnv -> DatabaseContext

206envContext = re_context

207envContext = re_context

@@ -544,9 +545,9 @@ evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

544 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes

545 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes

545 putStateContext $ currentContext { typeConstructorMapping = newTypes }

546 putStateContext $ currentContext { typeConstructorMapping = newTypes }

546

547

547−evalGraphRefDatabaseContextExpr (MultipleExpr exprs) = do

548+evalGraphRefDatabaseContextExpr (MultipleExpr exprs) =

548 --the multiple expressions must pass the same context around- not the old unmodified context

549 --the multiple expressions must pass the same context around- not the old unmodified context

549− mapM_ (\expr -> evalGraphRefDatabaseContextExpr expr) exprs

550+ mapM_ evalGraphRefDatabaseContextExpr exprs

550

551

551evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do

552evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do

552 currentContext <- getStateContext

553 currentContext <- getStateContext

@@ -576,7 +577,7 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg

576 context <- getStateContext

577 context <- getStateContext

577 graph <- dbcGraph

578 graph <- dbcGraph

578 --resolve atom arguments

579 --resolve atom arguments

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

580+ let eAtomTypes = mapM (runGraphRefRelationalExprM gfEnv . typeForGraphRefAtomExpr emptyAttributes) atomArgExprs

580 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

581 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

581 gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

582 gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

582 case eFunc of

583 case eFunc of

@@ -591,11 +592,13 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg

591 case eAtomTypes of

592 case eAtomTypes of

592 Left err -> dbErr err

593 Left err -> dbErr err

593 Right atomTypes -> do

594 Right atomTypes -> do

595+ let mValidTypes = zipWith (\ expType actType

594− let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of

596+ -> case atomTypeVerify expType actType of

595− Left err -> Just err

597+ Left err -> Just err

598+ Right _ -> Nothing)

596− Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)

599+ (dbcFuncType func) atomTypes

597 typeErrors = catMaybes mValidTypes

600 typeErrors = catMaybes mValidTypes

598− eAtomArgs = map (\arg -> runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr emptyTuple arg)) atomArgExprs

601+ eAtomArgs = map (runGraphRefRelationalExprM gfEnv . evalGraphRefAtomExpr emptyTuple) atomArgExprs

599 if length (lefts eAtomArgs) > 1 then

602 if length (lefts eAtomArgs) > 1 then

600 dbErr (someErrors (lefts eAtomArgs))

603 dbErr (someErrors (lefts eAtomArgs))

601 else if not (null typeErrors) then

604 else if not (null typeErrors) then

@@ -639,8 +642,7 @@ getDBCIOContext = dbc_context <$> RWS.get

639getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv

642getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv

640getDBCIORelationalExprEnv = do

643getDBCIORelationalExprEnv = do

641 context <- getDBCIOContext

644 context <- getDBCIOContext

642− env <- RWS.ask

643− pure $ mkRelationalExprEnv context (dbcio_graph env)

645+ mkRelationalExprEnv context . dbcio_graph <$> RWS.ask

644

646

645evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

647evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

646#if !defined(PM36_HASKELL_SCRIPTING)

648#if !defined(PM36_HASKELL_SCRIPTING)

@@ -827,7 +829,7 @@ typeForRelationalExpr expr = do

827 let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)

829 let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)

828 gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

830 gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

829 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

831 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

830− lift $ except $ runGf

832+ lift $ except runGf

831

833

832--returns a database context with all tuples removed

834--returns a database context with all tuples removed

833--this is useful for type checking and optimization

835--this is useful for type checking and optimization

@@ -929,7 +931,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName r

929 Right rel

931 Right rel

930

932

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

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

932−extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do

934+extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) =

933-- renv <- askEnv

935-- renv <- askEnv

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

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

935 case tupleExprCheckNewAttrName newAttrName relIn of

937 case tupleExprCheckNewAttrName newAttrName relIn of

@@ -971,7 +973,7 @@ evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName arguments tid) = do

971 throwError (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

973 throwError (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

972 else do

974 else do

973 let zippedArgs = zip (safeInit (atomFuncType func)) argTypes

975 let zippedArgs = zip (safeInit (atomFuncType func)) argTypes

974− mapM_ (\(expType, actType) -> do

976+ mapM_ (\(expType, actType) ->

975 lift $ except (atomTypeVerify expType actType)) zippedArgs

977 lift $ except (atomTypeVerify expType actType)) zippedArgs

976 evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments

978 evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments

977 case evalAtomFunction func evaldArgs of

979 case evalAtomFunction func evaldArgs of

@@ -1160,14 +1162,14 @@ evalGraphRefTupleExprs mAttrs (TupleExprs fixedMarker tupleExprL) = do

1160 pure (A.attributesFromList mostResolvedTypes)

1162 pure (A.attributesFromList mostResolvedTypes)

1161 --strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same

1163 --strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same

1162 tConsMap <- case singularTransactions tupleExprL of

1164 tConsMap <- case singularTransactions tupleExprL of

1163− SingularTransactionRef commonTransId -> do

1165+ SingularTransactionRef commonTransId ->

1164 typeConstructorMapping <$> gfDatabaseContextForMarker commonTransId

1166 typeConstructorMapping <$> gfDatabaseContextForMarker commonTransId

1165− NoTransactionsRef -> do

1167+ NoTransactionsRef ->

1166 typeConstructorMapping <$> gfDatabaseContextForMarker fixedMarker

1168 typeConstructorMapping <$> gfDatabaseContextForMarker fixedMarker

1167 -- if there are multiple transaction markers in the TupleExprs, then we can't assume a single type constructor mapping- this could be improved in the future, but if all the tuples are fully resolved, then we don't need further resolution

1169 -- if there are multiple transaction markers in the TupleExprs, then we can't assume a single type constructor mapping- this could be improved in the future, but if all the tuples are fully resolved, then we don't need further resolution

1168 _ -> throwError TupleExprsReferenceMultipleMarkersError

1170 _ -> throwError TupleExprsReferenceMultipleMarkersError

1169 lift $ except $ validateAttributes tConsMap finalAttrs

1171 lift $ except $ validateAttributes tConsMap finalAttrs

1170− mapM (\tup -> lift $ except $ resolveTypesInTuple finalAttrs tConsMap tup) tuples

1172+ mapM (lift . except . resolveTypesInTuple finalAttrs tConsMap) tuples

1171

1173

1172

1174

1173--resolveAttributes (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",IntegerAtomType),("b",TypeVariableType "b")]))) (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",TypeVariableType "a"),("b",TextAtomType)])))

1175--resolveAttributes (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",IntegerAtomType),("b",TypeVariableType "b")]))) (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",TypeVariableType "a"),("b",TextAtomType)])))

@@ -1313,7 +1315,7 @@ evalGraphRefRelationalExpr (Extend extendTupleExpr expr) = do

1313 rel <- evalGraphRefRelationalExpr expr

1315 rel <- evalGraphRefRelationalExpr expr

1314 (newAttrs, tupProc) <- extendGraphRefTupleExpressionProcessor rel extendTupleExpr

1316 (newAttrs, tupProc) <- extendGraphRefTupleExpressionProcessor rel extendTupleExpr

1315 lift $ except $ relMogrify tupProc newAttrs rel

1317 lift $ except $ relMogrify tupProc newAttrs rel

1316−evalGraphRefRelationalExpr expr@With{} = do

1318+evalGraphRefRelationalExpr expr@With{} =

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

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

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

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

1319 --strategy B implementation

1321 --strategy B implementation

@@ -1341,7 +1343,7 @@ typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAt

1341typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1343typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1342 mAttrs <- case mAttrExprs of

1344 mAttrs <- case mAttrExprs of

1343 Just attrExprs -> do

1345 Just attrExprs -> do

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

1346+ attrs <- mapM evalGraphRefAttributeExpr attrExprs

1345 pure (Just (attributesFromList attrs))

1347 pure (Just (attributesFromList attrs))

1346 Nothing -> pure Nothing

1348 Nothing -> pure Nothing

1347 tuples <- evalGraphRefTupleExprs mAttrs tupleExprs

1349 tuples <- evalGraphRefTupleExprs mAttrs tupleExprs

@@ -1386,9 +1388,9 @@ typeForGraphRefRelationalExpr (Restrict pred' expr) = do

1386 expr' <- typeForGraphRefRelationalExpr expr

1388 expr' <- typeForGraphRefRelationalExpr expr

1387 filt <- predicateRestrictionFilter (attributes expr') pred'

1389 filt <- predicateRestrictionFilter (attributes expr') pred'

1388 lift $ except $ restrict filt expr'

1390 lift $ except $ restrict filt expr'

1389−typeForGraphRefRelationalExpr Equals{} = do

1391+typeForGraphRefRelationalExpr Equals{} =

1390 pure relationFalse

1392 pure relationFalse

1391−typeForGraphRefRelationalExpr NotEquals{} = do

1393+typeForGraphRefRelationalExpr NotEquals{} =

1392 pure relationFalse

1394 pure relationFalse

1393typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do

1395typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do

1394 rel <- typeForGraphRefRelationalExpr expr

1396 rel <- typeForGraphRefRelationalExpr expr

@@ -1400,7 +1402,7 @@ typeForGraphRefRelationalExpr expr@(With withs _) = do

1400 case M.lookup macroName rvs of

1402 case M.lookup macroName rvs of

1401 Just _ -> lift $ except $ Left (RelVarAlreadyDefinedError macroName) --this error does not include the transaction marker, but should be good enough to identify the cause

1403 Just _ -> lift $ except $ Left (RelVarAlreadyDefinedError macroName) --this error does not include the transaction marker, but should be good enough to identify the cause

1402 Nothing -> pure ()

1404 Nothing -> pure ()

1403− mapM_ checkMacroName (map fst withs)

1405+ mapM_ (checkMacroName . fst) withs

1404 typeForGraphRefRelationalExpr expr'

1406 typeForGraphRefRelationalExpr expr'

1405

1407

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

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

@@ -1446,7 +1448,7 @@ evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1446evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr

1448evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr

1447

1449

1448mkEmptyRelVars :: RelationVariables -> RelationVariables

1450mkEmptyRelVars :: RelationVariables -> RelationVariables

1449−mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

1451+mkEmptyRelVars = M.map mkEmptyRelVar

1450 where

1452 where

1451 mkEmptyRelVar expr@MakeRelationFromExprs{} = expr --do not truncate here because we might lose essential type information in emptying the tuples

1453 mkEmptyRelVar expr@MakeRelationFromExprs{} = expr --do not truncate here because we might lose essential type information in emptying the tuples

1452 mkEmptyRelVar (MakeStaticRelation attrs _) = MakeStaticRelation attrs emptyTupleSet

1454 mkEmptyRelVar (MakeStaticRelation attrs _) = MakeStaticRelation attrs emptyTupleSet

@@ -1463,7 +1465,7 @@ mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

1463 mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1465 mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1464 mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1466 mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1465 mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)

1467 mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)

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

1468+ mkEmptyRelVar (With macros expr) = With (map (second mkEmptyRelVar) macros) (mkEmptyRelVar expr)

1467

1469

1468

1470

1469dbErr :: RelationalError -> DatabaseContextEvalMonad ()

1471dbErr :: RelationalError -> DatabaseContextEvalMonad ()

src/lib/ProjectM36/StaticOptimizer.hs+14−17

@@ -1,4 +1,3 @@

1−{-# LANGUAGE TypeSynonymInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

1{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

4module ProjectM36.StaticOptimizer where

3module ProjectM36.StaticOptimizer where

@@ -59,22 +58,22 @@ class Monad m => AskGraphContext m where

59 askContext :: m DatabaseContext

58 askContext :: m DatabaseContext

61instance AskGraphContext (ReaderT GraphRefSOptDatabaseContextExprEnv (ExceptT RelationalError Identity)) where

60instance AskGraphContext (ReaderT GraphRefSOptDatabaseContextExprEnv (ExceptT RelationalError Identity)) where

62− askGraph = odce_graph <$> ask

61+ askGraph = asks odce_graph

63− askContext = odce_context <$> ask

62+ askContext = asks odce_context

65instance AskGraphContext (ReaderT GraphRefSOptRelationalExprEnv (ExceptT RelationalError Identity)) where

64instance AskGraphContext (ReaderT GraphRefSOptRelationalExprEnv (ExceptT RelationalError Identity)) where

66− askGraph = ore_graph <$> ask

65+ askGraph = asks ore_graph

67 askContext = do

66 askContext = do

68− mctx <- ore_mcontext <$> ask

67+ mctx <- asks ore_mcontext

69 case mctx of

68 case mctx of

70 Nothing -> throwError NoUncommittedContextInEvalError

69 Nothing -> throwError NoUncommittedContextInEvalError

71 Just ctx -> pure ctx

70 Just ctx -> pure ctx

73askTransId :: GraphRefSOptDatabaseContextExprM TransactionId

72askTransId :: GraphRefSOptDatabaseContextExprM TransactionId

74−askTransId = odce_transId <$> ask

73+askTransId = asks odce_transId

76askMaybeContext :: GraphRefSOptRelationalExprM (Maybe DatabaseContext)

75askMaybeContext :: GraphRefSOptRelationalExprM (Maybe DatabaseContext)

77−askMaybeContext = ore_mcontext <$> ask

76+askMaybeContext = asks ore_mcontext

79optimizeDatabaseContextExpr :: DatabaseContextExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextExpr

78optimizeDatabaseContextExpr :: DatabaseContextExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextExpr

80optimizeDatabaseContextExpr expr = do

79optimizeDatabaseContextExpr expr = do

@@ -83,8 +82,8 @@ optimizeDatabaseContextExpr expr = do

84optimizeAndEvalDatabaseContextExpr :: Bool -> DatabaseContextExpr -> DatabaseContextEvalMonad ()

83optimizeAndEvalDatabaseContextExpr :: Bool -> DatabaseContextExpr -> DatabaseContextEvalMonad ()

85optimizeAndEvalDatabaseContextExpr optimize expr = do

84optimizeAndEvalDatabaseContextExpr optimize expr = do

86− graph <- dce_graph <$> ask

85+ graph <- asks dce_graph

87− transId <- dce_transId <$> ask

86+ transId <- asks dce_transId

88 context <- getStateContext

87 context <- getStateContext

89 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr expr)

88 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr expr)

90 eOptExpr = if optimize then

89 eOptExpr = if optimize then

@@ -105,9 +104,9 @@ optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do

105

104

106optimizeAndEvalDatabaseContextIOExpr :: DatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

105optimizeAndEvalDatabaseContextIOExpr :: DatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

107optimizeAndEvalDatabaseContextIOExpr expr = do

106optimizeAndEvalDatabaseContextIOExpr expr = do

108− transId <- dbcio_transId <$> ask

107+ transId <- asks dbcio_transId

109 ctx <- getDBCIOContext

108 ctx <- getDBCIOContext

110− graph <- dbcio_graph <$> ask

109+ graph <- asks dbcio_graph

111 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextIOExpr expr)

110 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextIOExpr expr)

112 eOptExpr = runGraphRefSOptDatabaseContextExprM transId ctx graph (optimizeDatabaseContextIOExpr gfExpr)

111 eOptExpr = runGraphRefSOptDatabaseContextExprM transId ctx graph (optimizeDatabaseContextIOExpr gfExpr)

113 case eOptExpr of

112 case eOptExpr of

@@ -164,8 +163,8 @@ optimizeGraphRefRelationalExpr' mctx graph expr =

164-- | optimize relational expression within database context expr monad

163-- | optimize relational expression within database context expr monad

165liftGraphRefRelExpr :: GraphRefSOptRelationalExprM a -> GraphRefSOptDatabaseContextExprM a

164liftGraphRefRelExpr :: GraphRefSOptRelationalExprM a -> GraphRefSOptDatabaseContextExprM a

166liftGraphRefRelExpr m = do

165liftGraphRefRelExpr m = do

167− context <- odce_context <$> ask

166+ context <- asks odce_context

168− graph <- odce_graph <$> ask

167+ graph <- asks odce_graph

169 lift $ except $ runGraphRefSOptRelationalExprM (Just context) graph m

168 lift $ except $ runGraphRefSOptRelationalExprM (Just context) graph m

170

169

171fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

170fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

@@ -358,10 +357,8 @@ applyStaticPredicateOptimization predi = do

358 OrPredicate pred1 pred2 -> do

357 OrPredicate pred1 pred2 -> do

359 optPredA <- applyStaticPredicateOptimization pred1

358 optPredA <- applyStaticPredicateOptimization pred1

360 optPredB <- applyStaticPredicateOptimization pred2

359 optPredB <- applyStaticPredicateOptimization pred2

361− if optPredA == optPredB then

360+ if (optPredA == optPredB) || isTrueExpr optPredA then

362 pure optPredA

361 pure optPredA

363− else if isTrueExpr optPredA then

364− pure optPredA -- True or x -> True

365 else if isTrueExpr optPredB then

362 else if isTrueExpr optPredB then

366 pure optPredB

363 pure optPredB

367 else

364 else

@@ -577,4 +574,4 @@ applyStaticRestrictionPushdown expr = case expr of

577

574

578-- no optimizations available

575-- no optimizations available

579optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr

576optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr

580−optimizeDatabaseContextIOExpr x = pure x

577+optimizeDatabaseContextIOExpr = pure

src/lib/ProjectM36/TransGraphPlanExpr.hsdeleted−5

@@ -1,5 +0,0 @@

1−module ProjectM36.TransGraphPlanExpr where

2−import ProjectM36.Base

3−-- used to create an execution plan which can potentially read from the query cache

4−

5−data TransGraphPlanExpr = ExecuteTransGraphRelationalExprPlan TransGraphRelationalExpr

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

@@ -47,7 +47,7 @@ type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup

48instance Binary TransGraphWithNameExpr

50−data TransGraphEvalEnv = TransGraphEvalEnv {

50+newtype TransGraphEvalEnv = TransGraphEvalEnv {

51 tge_graph :: TransactionGraph

52 }

@@ -169,7 +169,7 @@ evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr

169 AttributeEqualityPredicate attrName <$> expr'

170

171processTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr

172−processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) = do

172+processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) =

173 AttributeExtendTupleExpr attrName <$> processTransGraphAtomExpr expr

174

175processTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr

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

@@ -18,7 +18,7 @@ singleParent tid = tid NE.:| []

18filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

19filterTransactionInfoTransactions filterIds tinfo =

20 TransactionInfo { parents = case

21− NE.filter (\parent -> S.member parent filterIds) (parents tinfo) of

21+ NE.filter (`S.member` filterIds) (parents tinfo) of

22 [] -> rootParent

23 xs -> NE.fromList xs,

24 stamp = stamp tinfo }

@@ -43,7 +43,7 @@ subschemas :: Transaction -> Subschemas

43subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas

45fresh :: TransactionId -> UTCTime -> Schemas -> Transaction

46−fresh freshId stamp' newSchemas = Transaction freshId (TransactionInfo rootParent stamp') newSchemas

46+fresh freshId stamp' = Transaction freshId (TransactionInfo rootParent stamp')

48timestamp :: Transaction -> UTCTime

49timestamp (Transaction _ tinfo _) = stamp tinfo

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

@@ -102,7 +102,7 @@ writeRelVars sync transDir relvars = do

102 writeBSFileSync sync path (B.encode relvars)

103

104readRelVars :: FilePath -> IO RelationVariables

105−readRelVars transDir = do

105+readRelVars transDir =

106 B.decodeFile (relvarsPath transDir)

107

108writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO ()

src/lib/ProjectM36/TransactionGraph.hs+2−7

@@ -30,11 +30,6 @@ import Data.Monoid

30import Control.Arrow

31import Data.Maybe

32import Data.UUID.V4

33−#if __GLASGOW_HASKELL__ <= 802

34−import Data.Monoid

35−#endif

36−

37−--import Debug.Trace

39-- | Record a lookup for a specific transaction in the graph.

34-- | Record a lookup for a specific transaction in the graph.

40data TransactionIdLookup = TransactionIdLookup TransactionId |

35data TransactionIdLookup = TransactionIdLookup TransactionId |

@@ -79,7 +74,7 @@ freshTransactionGraph :: DatabaseContext -> IO (TransactionGraph, TransactionId)

79freshTransactionGraph ctx = do

74freshTransactionGraph ctx = do

80 now <- getCurrentTime

75 now <- getCurrentTime

81 freshId <- nextRandom

76 freshId <- nextRandom

82− pure $ (bootstrapTransactionGraph now freshId ctx, freshId)

77+ pure (bootstrapTransactionGraph now freshId ctx, freshId)

85emptyTransactionGraph :: TransactionGraph

80emptyTransactionGraph :: TransactionGraph

@@ -112,7 +107,7 @@ rootTransactions graph = S.filter isRootTransaction (transactionsForGraph graph)

112

107

113-- the first transaction has no parent - all other do have parents- merges have two parents

108-- the first transaction has no parent - all other do have parents- merges have two parents

114parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

109parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

115−parentTransactions trans graph = transactionsForIds (parentIds trans) graph

110+parentTransactions trans = transactionsForIds (parentIds trans)

116

111

117childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

112childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

118childTransactions trans graph = transactionsForIds childIds graph

113childTransactions trans graph = transactionsForIds childIds graph

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

@@ -47,7 +47,7 @@ unionMergeRelVars prefer relvarsA relvarsB = do

47 lookupA = findRel relvarsA

48 lookupB = findRel relvarsB

49 case (lookupA, lookupB) of

50− (Just relA, Just relB) -> do

50+ (Just relA, Just relB) ->

51 unionMergeRelation prefer relA relB

52 (Nothing, Just relB) -> pure relB

53 (Just relA, Nothing) -> pure relA

src/lib/ProjectM36/TransactionGraph/Persist.hs−3

@@ -32,9 +32,6 @@ import Control.Arrow

32import Data.Time.Clock

33import Data.Text.Read

34import System.FilePath.Glob

35−#if __GLASGOW_HASKELL__ <= 802

36−import Data.Monoid

37−#endif

39type LockFileHash = ByteString

36type LockFileHash = ByteString

src/lib/ProjectM36/Tupleable.hs−3

@@ -26,9 +26,6 @@ import ProjectM36.Error

26import ProjectM36.Tuple

27import ProjectM36.TupleSet

28import qualified Data.Set as S

29−#if __GLASGOW_HASKELL__ <= 802

30−import Data.Monoid

31−#endif

33{-import Data.Binary

30{-import Data.Binary

34import Control.DeepSeq

31import Control.DeepSeq

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

@@ -17,7 +17,7 @@ substituteWithNameMacros macros e@(RelationVariable rvname tid) =

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

18 case filter macroFilt macros of

19 [] -> e

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

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

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

22substituteWithNameMacros macros (Project attrs expr) =

23 Project attrs (substituteWithNameMacros macros expr)

test/TutorialD/Interpreter.hs+2−2

@@ -149,7 +149,7 @@ dateExampleRelTests = TestCase $ do

149 else Right tuple) suppliersRel

150 extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)]

151 testTups = [("x:=s where true", Right suppliersRel),

152− ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),

152+ ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == Right (TextAtom "London")) suppliersRel),

153 ("x:=s where false", Right $ Relation (R.attributes suppliersRel) emptyTupleSet),

154 ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (R.attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]),

155 ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntegerAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntegerAtomType]) (V.fromList [IntegerAtom 50])])),

@@ -157,7 +157,7 @@ dateExampleRelTests = TestCase $ do

157 --atom function tests

158 ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),

159 ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntegerAtom 5, RelationAtom suppliersRel])])),

160− ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == (Right $ TextAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (TextAtom "Boston")) tuple else Right tuple) suppliersRel),

160+ ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == Right (TextAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (TextAtom "Boston")) tuple else Right tuple) suppliersRel),

161 ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),

162 --relatom function tests

163 ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntegerAtom 1)])),