ddb2516 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP: non-incremental write to hard-coded database directory

ddb2516AgentM11 years ago

ProjectM36/Base.hs+42−11

compare with master

unifiedsplit

@@ -12,6 +12,9 @@ import GHC.Generics (Generic)

12import qualified Data.Vector as V

13import qualified Data.List as L

14import qualified Data.Text as T

15+import Data.Binary

16+import Data.Vector.Binary()

17+import ProjectM36.HashSetBinary()

16type StringType = T.Text

19type StringType = T.Text

@@ -23,7 +26,9 @@ data Atom = StringAtom StringType |

24instance NFData Atom where rnf = genericRnf

27instance NFData Atom where rnf = genericRnf

26−instance Hash.Hashable Atom

29+instance Hash.Hashable Atom

30+

31+instance Binary Atom

28data AtomType = StringAtomType |

33data AtomType = StringAtomType |

29 IntAtomType |

34 IntAtomType |

@@ -33,6 +38,7 @@ data AtomType = StringAtomType |

33 deriving (Eq, Show, Generic)

38 deriving (Eq, Show, Generic)

35instance NFData AtomType where rnf = genericRnf

40instance NFData AtomType where rnf = genericRnf

41+instance Binary AtomType

37type AttributeName = T.Text

43type AttributeName = T.Text

@@ -42,6 +48,8 @@ instance Hash.Hashable Attribute where

42 hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName

48 hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName

44instance NFData Attribute where rnf = genericRnf

50instance NFData Attribute where rnf = genericRnf

51+

52+instance Binary Attribute

46type Attributes = V.Vector Attribute

54type Attributes = V.Vector Attribute

@@ -68,6 +76,8 @@ instance Hash.Hashable RelationTuple where

68--maybe the attribute->int mapping should be stored once in the relation and then passed down when needed

76--maybe the attribute->int mapping should be stored once in the relation and then passed down when needed

69data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)

77data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)

79+instance Binary RelationTuple

80+

71instance Eq RelationTuple where

81instance Eq RelationTuple where

72 (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual

82 (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual

73 where

83 where

@@ -91,6 +101,8 @@ instance Hash.Hashable Relation where

91 HS.toList tupSet

101 HS.toList tupSet

92 where

102 where

93 sortedAttrs = map snd (sortedAttributesIndices attrs)

103 sortedAttrs = map snd (sortedAttributesIndices attrs)

104+

105+instance Binary Relation

106

95data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic)

107data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic)

96data RelationSizeInfinite = RelationSizeInfinite

108data RelationSizeInfinite = RelationSizeInfinite

@@ -115,17 +127,23 @@ data RelationalExpr where

115 NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr

127 NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr

116 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr

128 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr

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

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

118− deriving (Show,Eq)

130+ deriving (Show,Eq, Generic)

131+

132+instance Binary RelationalExpr

119

133

120data DatabaseContext = DatabaseContext {

134data DatabaseContext = DatabaseContext {

121 inclusionDependencies :: M.Map IncDepName InclusionDependency,

135 inclusionDependencies :: M.Map IncDepName InclusionDependency,

122 relationVariables :: M.Map RelVarName Relation,

136 relationVariables :: M.Map RelVarName Relation,

123 atomFunctions :: AtomFunctions

137 atomFunctions :: AtomFunctions

124− } deriving (Show)

138+ } deriving (Show, Generic)

139+

140+--instance Binary DatabaseContext

125

141

126type IncDepName = StringType

142type IncDepName = StringType

127

143

128−data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq)

144+data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic)

145+

146+instance Binary InclusionDependency

129

147

130--Database context expressions modify the database context while relational expressions do not

148--Database context expressions modify the database context while relational expressions do not

131data DatabaseExpr where

149data DatabaseExpr where

@@ -150,7 +168,9 @@ data RestrictionPredicateExpr where

150 RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)

168 RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)

151 AtomExprPredicate :: AtomExpr -> RestrictionPredicateExpr --atom must evaluate to boolean

169 AtomExprPredicate :: AtomExpr -> RestrictionPredicateExpr --atom must evaluate to boolean

152 AttributeEqualityPredicate :: AttributeName -> AtomExpr -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple

170 AttributeEqualityPredicate :: AttributeName -> AtomExpr -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple

153− deriving (Show, Eq)

171+ deriving (Show, Eq, Generic)

172+

173+instance Binary RestrictionPredicateExpr

154

174

155-- child + parent links

175-- child + parent links

156-- the string represents the branch name and can be used to find the named HEADs

176-- the string represents the branch name and can be used to find the named HEADs

@@ -169,10 +189,14 @@ transactionHeadsForGraph (TransactionGraph heads _) = heads

169

189

170data TransactionInfo = TransactionInfo UUID (S.Set UUID) | -- 1 parent + n children

190data TransactionInfo = TransactionInfo UUID (S.Set UUID) | -- 1 parent + n children

171 MergeTransactionInfo UUID UUID (S.Set UUID) -- 2 parents, n children

191 MergeTransactionInfo UUID UUID (S.Set UUID) -- 2 parents, n children

172− deriving(Show)

192+ deriving(Show, Generic)

193+

194+--instance Binary TransactionInfo

173

195

174data Transaction = Transaction UUID TransactionInfo DatabaseContext -- self uuid

196data Transaction = Transaction UUID TransactionInfo DatabaseContext -- self uuid

175− deriving (Show)

197+ deriving (Show, Generic)

198+

199+--instance Binary Transaction

176

200

177--represents an "in-progress" transaction which has not yet been added to the transaction graph

201--represents an "in-progress" transaction which has not yet been added to the transaction graph

178--one the transaction is "complete", it is committed and no longer can be changed

202--one the transaction is "complete", it is committed and no longer can be changed

@@ -196,11 +220,15 @@ data AtomExpr = AttributeAtomExpr AttributeName |

196 NakedAtomExpr Atom |

220 NakedAtomExpr Atom |

197 FunctionAtomExpr AtomFunctionName [AtomExpr] |

221 FunctionAtomExpr AtomFunctionName [AtomExpr] |

198 RelationAtomExpr RelationalExpr

222 RelationAtomExpr RelationalExpr

199− deriving (Eq,Show)

223+ deriving (Eq,Show,Generic)

224+

225+instance Binary AtomExpr

200

226

201--used to extend a relation

227--used to extend a relation

202data TupleExpr = AttributeTupleExpr AttributeName AtomExpr

228data TupleExpr = AttributeTupleExpr AttributeName AtomExpr

203− deriving (Show, Eq)

229+ deriving (Show, Eq, Generic)

230+

231+instance Binary TupleExpr

204

232

205--enumerates the list of functions available to be run as part of tuple expressions

233--enumerates the list of functions available to be run as part of tuple expressions

206type AtomFunctions = HS.HashSet AtomFunction

234type AtomFunctions = HS.HashSet AtomFunction

@@ -223,7 +251,10 @@ instance Show AtomFunction where

223 show aFunc = T.unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes

251 show aFunc = T.unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes

224 where

252 where

225 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))

253 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))

226−

254+

227data AttributeNames = AttributeNames (S.Set AttributeName) |

255data AttributeNames = AttributeNames (S.Set AttributeName) |

228 InvertedAttributeNames (S.Set AttributeName)

256 InvertedAttributeNames (S.Set AttributeName)

229− deriving (Eq, Show)

257+ deriving (Eq, Show, Generic)

258+

259+instance Binary AttributeNames

260+

ProjectM36/HashSetBinary.hsnew file+11

@@ -0,0 +1,11 @@

1+module ProjectM36.HashSetBinary where

2+import Data.Hashable

3+import qualified Data.HashSet as HS

4+import Data.Binary

6+instance (Binary a, Hashable a, Eq a) => Binary (HS.HashSet a) where

7+ put = put . HS.toList

8+ get = do

9+ list <- get :: (Binary a, Hashable a, Eq a) => Get [a]

10+ return (HS.fromList list)

11+

ProjectM36/Transaction.hs+3

@@ -136,3 +136,6 @@ walkChildTransactions seenTransSet graph trans =

136 err:_ -> Just err

137 _ -> Nothing

138

139+transactionParentUUIDs :: Transaction -> S.Set U.UUID

140+transactionParentUUIDs (Transaction _ (TransactionInfo pUUID _) _) = S.singleton pUUID

141+transactionParentUUIDs (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _) = S.fromList [pUUID1, pUUID2]

ProjectM36/TransactionGraph/Persist.hsnew file+75

@@ -0,0 +1,75 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module ProjectM36.TransactionGraph.Persist where

3+import ProjectM36.Base

4+import qualified Data.Binary as B

5+import System.Directory

6+import System.FilePath

7+import Data.List

8+import qualified Data.UUID as U

9+import qualified Data.Set as S

10+import qualified Data.Map as M

11+import qualified Data.HashSet as HS

12+import ProjectM36.Transaction

13+import qualified Data.ByteString.Lazy as BS

14+import qualified Data.Text.Encoding as TE

15+import qualified Data.Text as T

16+

17+{-

18+The "m36v1" file at the top-level of the destination directory contains the the transaction graph as a set of UUIDs referencing their parents (1 or more)

19+Each Transaction is written to it own directory named by its UUID. Partially written transactions UUIDs are prefixed with a "." to indicate incompleteness in the graph.

20+

21+-}

22+

23+--as a first pass, just write to the directory as if it's empty

24+--next pass, make the writing incremental by only writing new transactions at the heads

25+transactionGraphPersist :: FilePath -> TransactionGraph -> IO ()

26+transactionGraphPersist destDirectory graph = do

27+ mapM_ (writeTransaction destDirectory) $ S.toList (transactionsForGraph graph)

28+ writeGraphUUIDFile destDirectory graph

29+ return ()

30+

31+writeGraphUUIDFile :: FilePath -> TransactionGraph -> IO ()

32+writeGraphUUIDFile destDirectory (TransactionGraph _ transSet) = writeFile graphFile uuidInfo

33+ where

34+ graphFile = destDirectory </> "m36v1"

35+ uuidInfo = intercalate "\n" graphLines

36+ graphLines = S.toList $ S.map graphLine transSet

37+ graphLine trans = U.toString (transactionUUID trans) ++ " " ++ intercalate " " (S.toList (S.map U.toString $ transactionParentUUIDs trans))

38+

39+readGraphUUIDFile :: FilePath -> IO ()

40+readGraphUUIDFile destDirectory = undefined

41+

42+readTransaction :: FilePath -> U.UUID -> IO ()

43+readTransaction destDirectory transUUID = undefined

44+

45+writeTransaction :: FilePath -> Transaction -> IO ()

46+writeTransaction destDirectory trans = do

47+ let tempDestDir = takeDirectory destDirectory </> "." ++ takeFileName destDirectory

48+ relvarsDir = tempDestDir </> "relvars"

49+ incDepsDir = tempDestDir </> "incdeps"

50+ atomFuncsDir = tempDestDir </> "atomfuncs"

51+ context = transactionContext trans

52+ --create sub directories

53+ mapM_ createDirectory [tempDestDir, relvarsDir, incDepsDir, atomFuncsDir]

54+ --write relvars

55+ mapM_ (writeRelVar relvarsDir) $ M.toList (relationVariables context)

56+ --write inclusion dependencies

57+ mapM_ (writeIncDep incDepsDir) $ M.toList (inclusionDependencies context)

58+ --write atom functions

59+ mapM_ (writeAtomFunc atomFuncsDir) $ HS.toList (atomFunctions context)

60+ --move the temp directory to final location

61+ renameDirectory tempDestDir destDirectory

62+

63+writeRelVar :: FilePath -> (RelVarName, Relation) -> IO ()

64+writeRelVar relvarDestDir (relvarName, rel) = do

65+ let relvarPath = relvarDestDir </> T.unpack relvarName

66+ BS.writeFile relvarPath (B.encode rel)

67+

68+--to write the atom functions, we really some bytecode to write (GHCi bytecode?)

69+writeAtomFunc :: FilePath -> AtomFunction -> IO ()

70+writeAtomFunc atomFuncDestDir func = do

71+ BS.appendFile (atomFuncDestDir </> "atomFuncs") $ BS.fromStrict (TE.encodeUtf8 (atomFuncName func `T.append` "\n"))

72+

73+writeIncDep :: FilePath -> (IncDepName, InclusionDependency) -> IO ()

74+writeIncDep incDepDir (incDepName, incDep) = do

75+ BS.writeFile (incDepDir </> T.unpack incDepName) $ B.encode incDep

TutorialD/Interpreter.hs+10−9

@@ -6,6 +6,7 @@ import TutorialD.Interpreter.DatabaseExpr

6import TutorialD.Interpreter.TransactionGraphOperator

7import ProjectM36.Base

8import ProjectM36.Transaction

9+import ProjectM36.TransactionGraph.Persist

9import Text.Parsec

10import Text.Parsec

10import Text.Parsec.String

11import Text.Parsec.String

11import Control.Monad.State

12import Control.Monad.State

@@ -52,32 +53,32 @@ interpret freshUUID discon@(DisconnectedTransaction parentUUID context) graph in

52 Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph)

53 Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph)

53 Right (discon', graph', result') -> (result', discon', graph')

54 Right (discon', graph', result') -> (result', discon', graph')

55−

56−

57−reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()

56+reprLoop :: FilePath -> DisconnectedTransaction -> TransactionGraph -> IO ()

58−reprLoop currentTransaction graph = do

57+reprLoop transGraphDir currentTransaction graph = do

59 homeDirectory <- getHomeDirectory

58 homeDirectory <- getHomeDirectory

60 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}

59 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}

60+ --save the current transaction graph

61+ transactionGraphPersist transGraphDir graph

62 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText currentTransaction graph))

63 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText currentTransaction graph))

64− let roloop = reprLoop currentTransaction graph

65+ let roloop = reprLoop transGraphDir currentTransaction graph

65 case maybeLine of

66 case maybeLine of

66 Nothing -> return ()

67 Nothing -> return ()

67 Just line -> do

68 Just line -> do

68 newUUID <- nextRandom

69 newUUID <- nextRandom

69 case interpret newUUID currentTransaction graph line of

70 case interpret newUUID currentTransaction graph line of

70 (QuitResult, _, _) -> return ()

71 (QuitResult, _, _) -> return ()

71− (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERR: " `T.append` err) >> roloop

72+ (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERROR: " `T.append` err) >> roloop

72 (DisplayIOResult outio, updatedTrans, updatedGraph) -> do

73 (DisplayIOResult outio, updatedTrans, updatedGraph) -> do

73 outio

74 outio

74− reprLoop updatedTrans updatedGraph

75+ reprLoop transGraphDir updatedTrans updatedGraph

75 (DisplayResult out, updatedTrans, updatedGraph) -> do

76 (DisplayResult out, updatedTrans, updatedGraph) -> do

76 TIO.putStrLn out

77 TIO.putStrLn out

77− reprLoop updatedTrans updatedGraph

78+ reprLoop transGraphDir updatedTrans updatedGraph

78 (QuietSuccessResult, updatedTrans, updatedGraph) -> do

79 (QuietSuccessResult, updatedTrans, updatedGraph) -> do

79 TIO.putStrLn "Done."

80 TIO.putStrLn "Done."

80− reprLoop updatedTrans updatedGraph

81+ reprLoop transGraphDir updatedTrans updatedGraph

82--used by :dumpGraph

83--used by :dumpGraph

83{-

84{-

TutorialD/tutd.hs+5−4

@@ -9,8 +9,9 @@ main :: IO ()

9main = do

10 freshUUID <- nextRandom

11 let currentHeadName = "master"

12− let newGraph = bootstrapTransactionGraph freshUUID dateExamples

12+ newGraph = bootstrapTransactionGraph freshUUID dateExamples

13− let headTransaction = case transactionForHead currentHeadName newGraph of { Just x -> x; _ -> undefined}

13+ headTransaction = case transactionForHead currentHeadName newGraph of { Just x -> x; _ -> undefined}

14+ dbdir = "/tmp/testdb"

14− let currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)

15+ currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)

15− reprLoop currentTransaction newGraph

16+ reprLoop dbdir currentTransaction newGraph

project-m36.cabal+3−2

@@ -7,7 +7,7 @@ Category: Relational Algebra

7Cabal-Version: >= 1.2

9Library

10− Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,easyplot

10+ Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,easyplot,binary,filepath,directory,vector-binary-instances

11 Exposed-Modules: ProjectM36.Error,

12 ProjectM36.Transaction,

13 ProjectM36.Transaction.Show,

@@ -24,7 +24,8 @@ Library

24 ProjectM36.StaticOptimizer,

25 ProjectM36.Relation.Show.Term,

26 ProjectM36.Relation.Show.CSV,

27− ProjectM36.Relation.Show.Gnuplot

27+ ProjectM36.Relation.Show.Gnuplot,

28+ ProjectM36.TransactionGraph.Persist

28 GHC-Options: -Wall -rtsopts

29 GHC-Options: -Wall -rtsopts

30Executable tutd

31Executable tutd