ace7680 · project-m36 · git.iko.soy

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+1−3

compare with master

unifiedsplit

@@ -103,9 +103,7 @@ instance FromJSON Atom where

103 case atype of

104 TypeVariableType _ -> fail "cannot pass TypeVariableType over the wire"

105 caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"

106− RelationAtomType _ -> do

106+ RelationAtomType _ -> RelationAtom <$> o .: "val"

107− rel <- o .: "val"

108− pure $ RelationAtom rel

109 IntAtomType -> IntAtom <$> o .: "val"

107 IntAtomType -> IntAtom <$> o .: "val"

110 IntegerAtomType -> IntegerAtom <$> o .: "val"

108 IntegerAtomType -> IntegerAtom <$> o .: "val"

111 DoubleAtomType -> DoubleAtom <$> o .: "val"

109 DoubleAtomType -> DoubleAtom <$> o .: "val"

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

@@ -54,9 +54,8 @@ multilineSep :: Parser T.Text

54multilineSep = newline >> pure "\n"

55

56multipleDatabaseContextExprP :: Parser DatabaseContextExpr

57−multipleDatabaseContextExprP = do

57+multipleDatabaseContextExprP =

58− exprs <- sepBy1 databaseContextExprP semi

58+ MultipleExpr <$> sepBy1 databaseContextExprP semi

59− pure $ MultipleExpr exprs

60

59

61insertP :: Parser DatabaseContextExpr

60insertP :: Parser DatabaseContextExpr

62insertP = do

61insertP = do

src/bin/TutorialD/Interpreter/RelationalExpr.hs+1−3

@@ -66,9 +66,7 @@ tupleAtomExprP = do

66 pure (attributeName, atomExpr)

67

68projectP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

69−projectP = do

70− attrs <- braces attributeListP

69+projectP = Project <$> braces attributeListP

71− pure $ Project attrs

72

70

73renameClauseP :: Parser (T.Text, T.Text)

71renameClauseP :: Parser (T.Text, T.Text)

74renameClauseP = do

72renameClauseP = do

src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+1−3

@@ -29,9 +29,7 @@ transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <

29 (string "@" *> (TransactionStampHeadBacktrack <$> utcTimeP))

30

31backtrackP :: Parser Int

32−backtrackP = do

33− steps <- integer <|> pure 1

32+backtrackP = fromIntegral <$> integer <|> pure 1

34− pure (fromIntegral steps)

35

33

36transGraphRelationalOpP :: Parser TransGraphRelationalOperator

34transGraphRelationalOpP :: Parser TransGraphRelationalOperator

37transGraphRelationalOpP = showTransGraphRelationalOpP

35transGraphRelationalOpP = showTransGraphRelationalOpP

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

@@ -37,9 +37,8 @@ atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConst

37atomTypeForDataConstructorName dConsName atomTypesIn tConsList =

38 case findDataConstructor dConsName tConsList of

39 Nothing -> Left (NoSuchDataConstructorError dConsName)

40− Just (tCons, dCons) -> do

40+ Just (tCons, dCons) ->

41− typeVars <- resolveDataConstructorTypeVars dCons atomTypesIn tConsList

42− pure (ConstructedAtomType (TCD.name tCons) typeVars)

41+ ConstructedAtomType (TCD.name tCons) <$> resolveDataConstructorTypeVars dCons atomTypesIn tConsList

43

42

44atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType

43atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType

45atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss =

44atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss =

@@ -65,10 +64,9 @@ atomTypeForDataConstructor tConss dConsName atomArgTypes =

65 --lookup the data constructor

64 --lookup the data constructor

66 case findDataConstructor dConsName tConss of

65 case findDataConstructor dConsName tConss of

67 Nothing -> Left (NoSuchDataConstructorError dConsName)

66 Nothing -> Left (NoSuchDataConstructorError dConsName)

68− Just (tCons, dCons) -> do

67+ Just (tCons, dCons) ->

69 --validate that the type constructor arguments are fulfilled in the data constructor

68 --validate that the type constructor arguments are fulfilled in the data constructor

70− typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss

71− pure (ConstructedAtomType (TCD.name tCons) typeVars)

69+ ConstructedAtomType (TCD.name tCons) <$> resolveDataConstructorTypeVars dCons atomArgTypes tConss

72

70

73-- | Walks the data and type constructors to extract the type variable map.

71-- | Walks the data and type constructors to extract the type variable map.

74resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap

72resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap

@@ -156,9 +154,8 @@ findTypeConstructor name = foldr tConsFolder Nothing

156 accum

154 accum

157

155

158resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

156resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

159−resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do

157+resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) =

160− tVarMap <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

158+ ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

161− pure (ConstructedAtomType tConsName tVarMap)

162resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

159resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

163 Right typeFromRelation

160 Right typeFromRelation

164 else

161 else

src/lib/ProjectM36/Client.hs+5−8

@@ -330,8 +330,7 @@ connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notific

330 liftIO $ putMVar connStatus (Left LoginError)

331 else

332 liftIO $ putMVar connStatus (Right $ RemoteProcessConnection RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport})

333− status <- takeMVar connStatus

333+ takeMVar connStatus

334− pure status

335

334

336connectPersistentProjectM36 :: PersistenceStrategy ->

335connectPersistentProjectM36 :: PersistenceStrategy ->

337 DiskSync ->

336 DiskSync ->

@@ -481,9 +480,8 @@ remoteCall (RemoteProcessConnection conf) arg = runProcessResult localNode $ do

481 serverProcessId = rProcessId conf

480 serverProcessId = rProcessId conf

482

481

483sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session)

482sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session)

484−sessionForSessionId sessionId sessions = do

483+sessionForSessionId sessionId sessions =

485− maybeSession <- STMMap.lookup sessionId sessions

486− pure $ maybe (Left $ NoSuchSessionError sessionId) Right maybeSession

484+ maybe (Left $ NoSuchSessionError sessionId) Right <$> STMMap.lookup sessionId sessions

487

485

488schemaForSessionId :: Session -> STM (Either RelationalError Schema)

486schemaForSessionId :: Session -> STM (Either RelationalError Schema)

489schemaForSessionId session = do

487schemaForSessionId session = do

@@ -890,9 +888,8 @@ transactionGraphAsRelation sessionId (InProcessConnection conf) = do

890 eSession <- sessionForSessionId sessionId sessions

888 eSession <- sessionForSessionId sessionId sessions

891 case eSession of

889 case eSession of

892 Left err -> pure $ Left err

890 Left err -> pure $ Left err

893− Right session -> do

891+ Right session ->

894− graph <- readTVar tvar

895− pure $ graphAsRelation (Sess.disconnectedTransaction session) graph

892+ graphAsRelation (Sess.disconnectedTransaction session) <$> readTVar tvar

896

893

897transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId)

894transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId)

898

895

src/lib/ProjectM36/DataTypes/Interval.hs+2−3

@@ -89,9 +89,8 @@ intervalAtomFunctions = HS.fromList [

89 atomFuncType = [IntervalAtomType (TypeVariableType "a"),

90 IntervalAtomType (TypeVariableType "a"),

91 BoolAtomType],

92− atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) -> do

92+ atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) ->

93− res <- intervalOverlaps i1 i2

93+ BoolAtom <$> intervalOverlaps i1 i2

94− pure (BoolAtom res)

95 }]

94 }]

96

95

97

96

src/lib/ProjectM36/DataTypes/List.hs+2−3

@@ -37,9 +37,8 @@ listAtomFunctions = HS.fromList [

37 AtomFunction {

38 atomFuncName = "length",

39 atomFuncType = [listAtomType (TypeVariableType "a"), IntAtomType],

40− atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> do

40+ atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) ->

41− c <- listLength listAtom

42− pure (IntAtom (fromIntegral c)))

41+ IntAtom . fromIntegral <$> listLength listAtom)

43 },

42 },

44 AtomFunction {

43 AtomFunction {

45 atomFuncName = "maybeHead",

44 atomFuncName = "maybeHead",

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

@@ -317,9 +317,8 @@ relationVariablesAsRelation relVarMap = mkRelationFromList attrs tups

317

318-- | Randomly resort the tuples. This is useful for emphasizing that two relations are equal even when they are printed to the console in different orders.

319randomizeTupleOrder :: MonadRandom m => Relation -> m Relation

320−randomizeTupleOrder (Relation attrs tupSet) = do

320+randomizeTupleOrder (Relation attrs tupSet) =

321− newTupSet <- shuffleM (asList tupSet)

321+ Relation attrs . RelationTupleSet <$> shuffleM (asList tupSet)

322− pure (Relation attrs (RelationTupleSet newTupSet))

323

322

324-- returns a tuple from the tupleset- this is useful for priming folds over the tuples

323-- returns a tuple from the tupleset- this is useful for priming folds over the tuples

325oneTuple :: Relation -> Maybe RelationTuple

324oneTuple :: Relation -> Maybe RelationTuple

src/lib/ProjectM36/Relation/Parse/CSV.hs+5−5

@@ -60,9 +60,8 @@ parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Pars

60parseCSVAtomP _ _ IntegerAtomType = Right . IntegerAtom <$> APT.decimal

61parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal

62parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double

63−parseCSVAtomP _ _ TextAtomType = do

63+parseCSVAtomP _ _ TextAtomType =

64− s <- quotedString <|> takeToEndOfData

64+ Right . TextAtom <$> (quotedString <|> takeToEndOfData)

65− pure (Right (TextAtom s))

66parseCSVAtomP _ _ DayAtomType = do

65parseCSVAtomP _ _ DayAtomType = do

67 dString <- T.unpack <$> takeToEndOfData

66 dString <- T.unpack <$> takeToEndOfData

68 case readMaybe dString of

67 case readMaybe dString of

@@ -94,8 +93,9 @@ parseCSVAtomP attrName tConsMap (IntervalAtomType iType) = do

94 case eEndv of

93 case eEndv of

95 Left err -> pure (Left err)

94 Left err -> pure (Left err)

96 Right endv -> do

95 Right endv -> do

97− end <- (APT.char ']' >> pure False) <|> (APT.char ')' >> pure True)

96+ let end = (APT.char ']' >> pure False) <|>

97+ (APT.char ')' >> pure True)

98− pure (Right (IntervalAtom beginv endv begin end))

98+ Right . IntervalAtom beginv endv begin <$> end

99parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) = do

100 dConsName <- capitalizedIdentifier

101 APT.skipSpace

src/lib/ProjectM36/RelationalExpression.hs+4−8

@@ -161,9 +161,8 @@ evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

161 -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible

162 runExceptT $ do

163 mAttrs <- case mAttrExprs of

164− Just _ -> do

164+ Just _ ->

165− attrs <- mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)

165+ Just . A.attributesFromList <$> mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)

166− pure (Just (A.attributesFromList attrs))

167 Nothing -> pure Nothing

166 Nothing -> pure Nothing

168 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

167 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

169 let attrs = fromMaybe firstTupleAttrs mAttrs

168 let attrs = fromMaybe firstTupleAttrs mAttrs

@@ -646,9 +645,7 @@ predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))

646predicateRestrictionFilter attrs (NotPredicate expr) =

645predicateRestrictionFilter attrs (NotPredicate expr) =

647 runExceptT $ do

646 runExceptT $ do

648 exprv <- liftE (predicateRestrictionFilter attrs expr)

647 exprv <- liftE (predicateRestrictionFilter attrs expr)

649− pure (\x -> do

648+ pure (fmap not . exprv)

650− ev <- exprv x

651− pure (not ev))

652

649

653--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here

650--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here

654predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

651predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

@@ -813,8 +810,7 @@ typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

813 runExceptT $ do

810 runExceptT $ do

814 argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs

811 argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs

815 context <- fmap stateElemsContext (lift ask)

812 context <- fmap stateElemsContext (lift ask)

816− aType <- either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)

813+ either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)

817− pure aType

818

814

819-- | Validate that the type of the AtomExpr matches the expected type.

815-- | Validate that the type of the AtomExpr matches the expected type.

820verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)

816verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)

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

@@ -158,12 +158,11 @@ compileScript funcType script = do

158 mErr <- typeCheckScript funcType script

159 case mErr of

160 Just err -> pure (Left err)

161− Nothing -> do

161+ Nothing ->

162 --catch exception here

163 --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example.

164 -- we can't use dynCompileExpr here because

165− func <- compileExpr sScript

166− pure $ Right (unsafeCoerce func)

165+ Right . unsafeCoerce <$> compileExpr sScript

167

166

168typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)

167typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)

169typeCheckScript expectedType inp = do

168typeCheckScript expectedType inp = do

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

@@ -68,8 +68,8 @@ evalTransGraphRelationalExpr (Join exprA exprB) graph = do

68 exprB' <- evalTransGraphRelationalExpr exprB graph

69 pure (Join exprA' exprB')

70evalTransGraphRelationalExpr (Rename attrName1 attrName2 expr) graph = do

71− expr' <- evalTransGraphRelationalExpr expr graph

71+ let expr' = evalTransGraphRelationalExpr expr graph

72− pure (Rename attrName1 attrName2 expr')

72+ Rename attrName1 attrName2 <$> expr'

73evalTransGraphRelationalExpr (Difference exprA exprB) graph = do

74 exprA' <- evalTransGraphRelationalExpr exprA graph

75 exprB' <- evalTransGraphRelationalExpr exprB graph

@@ -79,8 +79,8 @@ evalTransGraphRelationalExpr (Group transAttrNames attrName expr) graph = do

79 attrNames <- evalTransAttributeNames transAttrNames graph

80 pure (Group attrNames attrName expr')

81evalTransGraphRelationalExpr (Ungroup attrName expr) graph = do

82− expr' <- evalTransGraphRelationalExpr expr graph

82+ let expr' = evalTransGraphRelationalExpr expr graph

83− pure (Ungroup attrName expr')

83+ Ungroup attrName <$> expr'

84evalTransGraphRelationalExpr (Restrict predicateExpr expr) graph = do

85 expr' <- evalTransGraphRelationalExpr expr graph

86 predicateExpr' <- evalTransGraphRestrictionPredicateExpr predicateExpr graph

@@ -100,11 +100,11 @@ evalTransGraphRelationalExpr (Extend extendExpr expr) graph = do

100

101evalTransGraphTupleExpr :: TransactionGraph -> TransGraphTupleExpr -> Either RelationalError TupleExpr

102evalTransGraphTupleExpr graph (TupleExpr attrMap) = do

103− attrAssoc <- mapM (\(attrName, atomExpr) -> do

103+ let attrAssoc = mapM (\(attrName, atomExpr) -> do

104 aExpr <- evalTransGraphAtomExpr graph atomExpr

105 pure (attrName, aExpr)

106 ) (M.toList attrMap)

107− pure (TupleExpr (M.fromList attrAssoc))

107+ TupleExpr . M.fromList <$> attrAssoc

108

109evalTransGraphAtomExpr :: TransactionGraph -> TransGraphAtomExpr -> Either RelationalError AtomExpr

110evalTransGraphAtomExpr _ (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname

@@ -116,8 +116,8 @@ evalTransGraphAtomExpr graph (FunctionAtomExpr funcName args tLookup) = do

116 atom <- runReader (evalAtomExpr emptyTuple (FunctionAtomExpr funcName args' ())) (RelationalExprStateElems (concreteDatabaseContext trans))

117 pure (NakedAtomExpr atom)

118evalTransGraphAtomExpr graph (RelationAtomExpr expr) = do

119− expr' <- evalTransGraphRelationalExpr expr graph

119+ let expr' = evalTransGraphRelationalExpr expr graph

120− pure (RelationAtomExpr expr')

120+ RelationAtomExpr <$> expr'

121evalTransGraphAtomExpr graph (ConstructedAtomExpr dConsName args tLookup) = do

122 trans <- lookupTransaction graph tLookup

123 args' <- mapM (evalTransGraphAtomExpr graph) args

@@ -135,22 +135,22 @@ evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) graph = do

135 exprB' <- evalTransGraphRestrictionPredicateExpr exprB graph

136 pure (OrPredicate exprA' exprB')

137evalTransGraphRestrictionPredicateExpr (NotPredicate expr) graph = do

138− expr' <- evalTransGraphRestrictionPredicateExpr expr graph

138+ let expr' = evalTransGraphRestrictionPredicateExpr expr graph

139− pure (NotPredicate expr')

139+ NotPredicate <$> expr'

140evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) graph = do

141− expr' <- evalTransGraphRelationalExpr expr graph

141+ let expr' = evalTransGraphRelationalExpr expr graph

142− pure (RelationalExprPredicate expr')

142+ RelationalExprPredicate <$> expr'

143evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) graph = do

144− expr' <- evalTransGraphAtomExpr graph expr

144+ let expr' = evalTransGraphAtomExpr graph expr

145− pure (AtomExprPredicate expr')

145+ AtomExprPredicate <$> expr'

146evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) graph = do

147− expr' <- evalTransGraphAtomExpr graph expr

147+ let expr' = evalTransGraphAtomExpr graph expr

148− pure (AttributeEqualityPredicate attrName expr')

148+ AttributeEqualityPredicate attrName <$> expr'

149

150evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransactionGraph -> Either RelationalError ExtendTupleExpr

151evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) graph = do

152− expr' <- evalTransGraphAtomExpr graph expr

152+ let expr' = evalTransGraphAtomExpr graph expr

153− pure (AttributeExtendTupleExpr attrName expr')

153+ AttributeExtendTupleExpr attrName <$> expr'

154

155evalTransGraphAttributeExpr :: TransactionGraph -> TransGraphAttributeExpr -> Either RelationalError AttributeExpr

156evalTransGraphAttributeExpr graph (AttributeAndTypeNameExpr attrName tCons tLookup) = do

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

@@ -321,8 +321,8 @@ evalROGraphOp discon graph ShowGraph = do

321-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

322createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

323createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

324− selectedTrans <- validateHeadName selectedBranch graph t2

324+ let selectedTrans = validateHeadName selectedBranch graph t2

325− pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) (schemas selectedTrans)

325+ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) . schemas <$> selectedTrans

326

327-- merge functions, relvars, individually

328createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2

src/lib/ProjectM36/TransactionGraph/Persist.hs+4−5

@@ -83,9 +83,8 @@ setupDatabaseDir sync dbdir bootstrapGraph = do

83 locker <- openLockFile (lockFilePath dbdir)

84 gDigest <- bracket_ (lockFile locker WriteLock) (unlockFile locker) (readGraphTransactionIdFileDigest dbdir)

85 pure (Right (locker, gDigest))

86− else if not m36exists then do

86+ else if not m36exists then

87− locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph

87+ Right <$> bootstrapDatabaseDir sync dbdir bootstrapGraph

88− pure (Right locks)

89 else

88 else

90 pure (Left (InvalidDirectoryError dbdir))

89 pure (Left (InvalidDirectoryError dbdir))

91{-

90{-

@@ -201,8 +200,8 @@ writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = w

201

200

202readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash

201readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash

203readGraphTransactionIdFileDigest dbdir = do

202readGraphTransactionIdFileDigest dbdir = do

204− graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

203+ let graphTransactionIdData = TIO.readFile (transactionLogPath dbdir)

205− pure (SHA256.hash (encodeUtf8 graphTransactionIdData))

204+ SHA256.hash . encodeUtf8 <$> graphTransactionIdData

206

205

207readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])])

206readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])])

208readGraphTransactionIdFile dbdir = do

207readGraphTransactionIdFile dbdir = do