ddb2516 · project-m36 · git.iko.soy

git.iko.soy/project-m36

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

commitddb2516d23f53398058d3cb466e835589509df70 authorAgentM <agentm@themactionfaction.com> dateFri 26 Jun 2015, 22:47 (11 years ago) parent59ca1a8

7 files changed+149−26

compare with master

unifiedsplit

ProjectM36/Base.hs+42−11 ProjectM36/HashSetBinary.hs+11 ProjectM36/Transaction.hs+3 ProjectM36/TransactionGraph/Persist.hs+75 TutorialD/Interpreter.hs+10−9 TutorialD/tutd.hs+5−4 project-m36.cabal+3−2

ProjectM36/Base.hs+42−11

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

1212import qualified Data.Vector as V

1313import qualified Data.List as L

1414import qualified Data.Text as T

15+import Data.Binary

16+import Data.Vector.Binary()

17+import ProjectM36.HashSetBinary()

1518

1619type StringType = T.Text

1720

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

2326

2427instance NFData Atom where rnf = genericRnf

2528

26−instance Hash.Hashable Atom

29+instance Hash.Hashable Atom

30+

31+instance Binary Atom

2732

2833data AtomType = StringAtomType |

2934 IntAtomType |

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

3338 deriving (Eq, Show, Generic)

3439

3540instance NFData AtomType where rnf = genericRnf

41+instance Binary AtomType

3642

3743type AttributeName = T.Text

3844

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

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

4349

4450instance NFData Attribute where rnf = genericRnf

51+

52+instance Binary Attribute

4553

4654type Attributes = V.Vector Attribute

4755

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

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

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

7078

79+instance Binary RelationTuple

80+

7181instance Eq RelationTuple where

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

7383 where

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

91101 HS.toList tupSet

92102 where

93103 sortedAttrs = map snd (sortedAttributesIndices attrs)

104+

105+instance Binary Relation

94106

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

96108data RelationSizeInfinite = RelationSizeInfinite

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

115127 NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr

116128 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr

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

119133

120134data DatabaseContext = DatabaseContext {

121135 inclusionDependencies :: M.Map IncDepName InclusionDependency,

122136 relationVariables :: M.Map RelVarName Relation,

123137 atomFunctions :: AtomFunctions

124− } deriving (Show)

138+ } deriving (Show, Generic)

139+

140+--instance Binary DatabaseContext

125141

126142type IncDepName = StringType

127143

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

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

145+

146+instance Binary InclusionDependency

129147

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

131149data DatabaseExpr where

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

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

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

152170 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

154174

155175-- child + parent links

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

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

169189

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

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

172− deriving(Show)

192+ deriving(Show, Generic)

193+

194+--instance Binary TransactionInfo

173195

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

175− deriving (Show)

197+ deriving (Show, Generic)

198+

199+--instance Binary Transaction

176200

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

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

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

196220 NakedAtomExpr Atom |

197221 FunctionAtomExpr AtomFunctionName [AtomExpr] |

198222 RelationAtomExpr RelationalExpr

199− deriving (Eq,Show)

223+ deriving (Eq,Show,Generic)

224+

225+instance Binary AtomExpr

200226

201227--used to extend a relation

202228data TupleExpr = AttributeTupleExpr AttributeName AtomExpr

203− deriving (Show, Eq)

229+ deriving (Show, Eq, Generic)

230+

231+instance Binary TupleExpr

204232

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

206234type AtomFunctions = HS.HashSet AtomFunction

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

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

224252 where

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

226−

254+

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

228256 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 =

136136 err:_ -> Just err

137137 _ -> Nothing

138138

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

66import TutorialD.Interpreter.TransactionGraphOperator

77import ProjectM36.Base

88import ProjectM36.Transaction

9+import ProjectM36.TransactionGraph.Persist

910import Text.Parsec

1011import Text.Parsec.String

1112import Control.Monad.State

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

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

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

5455

55−

56−

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

58−reprLoop currentTransaction graph = do

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

57+reprLoop transGraphDir currentTransaction graph = do

5958 homeDirectory <- getHomeDirectory

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

60+ --save the current transaction graph

61+ transactionGraphPersist transGraphDir graph

6162

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

6364

64− let roloop = reprLoop currentTransaction graph

65+ let roloop = reprLoop transGraphDir currentTransaction graph

6566 case maybeLine of

6667 Nothing -> return ()

6768 Just line -> do

6869 newUUID <- nextRandom

6970 case interpret newUUID currentTransaction graph line of

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

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

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

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

7374 outio

74− reprLoop updatedTrans updatedGraph

75+ reprLoop transGraphDir updatedTrans updatedGraph

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

7677 TIO.putStrLn out

77− reprLoop updatedTrans updatedGraph

78+ reprLoop transGraphDir updatedTrans updatedGraph

7879 (QuietSuccessResult, updatedTrans, updatedGraph) -> do

7980 TIO.putStrLn "Done."

80− reprLoop updatedTrans updatedGraph

81+ reprLoop transGraphDir updatedTrans updatedGraph

8182

8283--used by :dumpGraph

8384{-

TutorialD/tutd.hs+5−4

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

99main = do

1010 freshUUID <- nextRandom

1111 let currentHeadName = "master"

12− let newGraph = bootstrapTransactionGraph freshUUID dateExamples

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

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

15− reprLoop currentTransaction newGraph

12+ newGraph = bootstrapTransactionGraph freshUUID dateExamples

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

14+ dbdir = "/tmp/testdb"

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

16+ reprLoop dbdir currentTransaction newGraph

1617

project-m36.cabal+3−2

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

77Cabal-Version: >= 1.2

99Library

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

1111 Exposed-Modules: ProjectM36.Error,

1212 ProjectM36.Transaction,

1313 ProjectM36.Transaction.Show,

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

2424 ProjectM36.StaticOptimizer,

2525 ProjectM36.Relation.Show.Term,

2626 ProjectM36.Relation.Show.CSV,

27− ProjectM36.Relation.Show.Gnuplot

27+ ProjectM36.Relation.Show.Gnuplot,

28+ ProjectM36.TransactionGraph.Persist

2829 GHC-Options: -Wall -rtsopts

2930

3031Executable tutd