56286b0 · project-m36 · git.iko.soy

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

compare with master

unifiedsplit

@@ -77,15 +77,12 @@ defineP = do

77undefineP :: Parser DatabaseContextExpr

78undefineP = do

79 reservedOp "undefine"

80− relVarName <- identifier

80+ Undefine <$> identifier

81− return $ Undefine relVarName

82

81

83deleteP :: Parser DatabaseContextExpr

82deleteP :: Parser DatabaseContextExpr

84deleteP = do

83deleteP = do

85 reservedOp "delete"

84 reservedOp "delete"

86− relVarName <- identifier

87− predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)

85+ Delete <$> identifier <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)

88− return $ Delete relVarName predicate

89

86

90updateP :: Parser DatabaseContextExpr

87updateP :: Parser DatabaseContextExpr

91updateP = do

88updateP = do

src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+5−10

@@ -30,20 +30,17 @@ data RODatabaseContextOperator where

30typeP :: Parser RODatabaseContextOperator

31typeP = do

32 reservedOp ":type"

33− expr <- relExprP

33+ ShowRelationType <$> relExprP

34− return $ ShowRelationType expr

35

34

36showRelP :: Parser RODatabaseContextOperator

35showRelP :: Parser RODatabaseContextOperator

37showRelP = do

36showRelP = do

38 reservedOp ":showexpr"

37 reservedOp ":showexpr"

39− expr <- relExprP

38+ ShowRelation <$> relExprP

40− return $ ShowRelation expr

41

39

42showPlanP :: Parser RODatabaseContextOperator

40showPlanP :: Parser RODatabaseContextOperator

43showPlanP = do

41showPlanP = do

44 reservedOp ":showplan"

42 reservedOp ":showplan"

45− expr <- databaseContextExprP

43+ ShowPlan <$> databaseContextExprP

46− return $ ShowPlan expr

47

44

48showTypesP :: Parser RODatabaseContextOperator

45showTypesP :: Parser RODatabaseContextOperator

49showTypesP = reserved ":showtypes" >> pure ShowTypes

46showTypesP = reserved ":showtypes" >> pure ShowTypes

@@ -59,14 +56,12 @@ quitP = do

59showConstraintsP :: Parser RODatabaseContextOperator

56showConstraintsP :: Parser RODatabaseContextOperator

60showConstraintsP = do

57showConstraintsP = do

61 reservedOp ":constraints"

58 reservedOp ":constraints"

62− constraintName <- option "" identifier

59+ ShowConstraint <$> option "" identifier

63− return $ ShowConstraint constraintName

64

60

65plotRelExprP :: Parser RODatabaseContextOperator

61plotRelExprP :: Parser RODatabaseContextOperator

66plotRelExprP = do

62plotRelExprP = do

67 reserved ":plotexpr"

63 reserved ":plotexpr"

68− expr <- relExprP

64+ PlotRelation <$> relExprP

69− return $ PlotRelation expr

70

65

71roDatabaseContextOperatorP :: Parser RODatabaseContextOperator

66roDatabaseContextOperatorP :: Parser RODatabaseContextOperator

72roDatabaseContextOperatorP = typeP

67roDatabaseContextOperatorP = typeP

src/bin/TutorialD/Interpreter/RelationalExpr.hs+8−16

@@ -112,8 +112,7 @@ ungroupP = do

112extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

113extendP = do

114 reservedOp ":"

115− tupleExpr <- braces extendTupleExpressionP

115+ Extend <$> braces extendTupleExpressionP

116− return $ Extend tupleExpr

117

116

118semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)

117semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)

119semijoinP = do

118semijoinP = do

@@ -169,17 +168,15 @@ restrictionPredicateP = makeExprParser predicateTerm predicateOperators

169 <|> relationalBooleanExprP

168 <|> relationalBooleanExprP

170

169

171relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

170relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

172−relationalBooleanExprP = do

171+relationalBooleanExprP =

173− relexpr <- parens relExprP <|> relTerm

174 --we can't actually detect if the type is relational boolean, so we just pass it to the next phase

172 --we can't actually detect if the type is relational boolean, so we just pass it to the next phase

175− return $ RelationalExprPredicate relexpr

173+ RelationalExprPredicate <$> (parens relExprP <|> relTerm)

176

174

177restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

175restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

178restrictionAttributeEqualityP = do

176restrictionAttributeEqualityP = do

179 attributeName <- identifier

177 attributeName <- identifier

180 reservedOp "="

178 reservedOp "="

181− atomexpr <- atomExprP

182− return $ AttributeEqualityPredicate attributeName atomexpr

179+ AttributeEqualityPredicate attributeName <$> atomExprP

183

180

184restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"

181restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"

185restrictionAtomExprP = do

182restrictionAtomExprP = do

@@ -196,8 +193,7 @@ attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTuple

196attributeExtendTupleExpressionP = do

193attributeExtendTupleExpressionP = do

197 newAttr <- identifier

194 newAttr <- identifier

198 reservedOp ":="

195 reservedOp ":="

199− atom <- atomExprP

200− return $ AttributeExtendTupleExpr newAttr atom

196+ AttributeExtendTupleExpr newAttr <$> atomExprP

201

197

202atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

198atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

203atomExprP = consumeAtomExprP True

199atomExprP = consumeAtomExprP True

@@ -213,8 +209,7 @@ consumeAtomExprP consume = try functionAtomExprP <|>

213attributeAtomExprP :: Parser (AtomExprBase a)

209attributeAtomExprP :: Parser (AtomExprBase a)

214attributeAtomExprP = do

210attributeAtomExprP = do

215 _ <- string "@"

211 _ <- string "@"

216− attrName <- identifier

212+ AttributeAtomExpr <$> identifier

217− return $ AttributeAtomExpr attrName

218

213

219nakedAtomExprP :: Parser (AtomExprBase a)

214nakedAtomExprP :: Parser (AtomExprBase a)

220nakedAtomExprP = NakedAtomExpr <$> atomP

215nakedAtomExprP = NakedAtomExpr <$> atomP

@@ -234,11 +229,8 @@ atomP = stringAtomP <|>

234 boolAtomP

229 boolAtomP

235

230

236functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

231functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

237−functionAtomExprP = do

232+functionAtomExprP =

238− funcName <- identifier

239− argList <- parens (sepBy atomExprP comma)

233+ FunctionAtomExpr <$> identifier <*> parens (sepBy atomExprP comma) <*> parseMarkerP

240− marker <- parseMarkerP

241− return $ FunctionAtomExpr funcName argList marker

242

234

243relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

235relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

244relationalAtomExprP = RelationAtomExpr <$> relExprP

236relationalAtomExprP = RelationAtomExpr <$> relExprP

src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs+3−6

@@ -22,14 +22,12 @@ autoMergeToHeadP = do

22jumpToHeadP :: Parser TransactionGraphOperator

23jumpToHeadP = do

24 reservedOp ":jumphead"

25− headid <- identifier

25+ JumpToHead <$> identifier

26− return $ JumpToHead headid

27

26

28jumpToTransactionP :: Parser TransactionGraphOperator

27jumpToTransactionP :: Parser TransactionGraphOperator

29jumpToTransactionP = do

28jumpToTransactionP = do

30 reservedOp ":jump"

29 reservedOp ":jump"

31− uuid <- uuidP

30+ JumpToTransaction <$> uuidP

32− return $ JumpToTransaction uuid

33

31

34walkBackToTimeP :: Parser TransactionGraphOperator

32walkBackToTimeP :: Parser TransactionGraphOperator

35walkBackToTimeP = do

33walkBackToTimeP = do

@@ -39,8 +37,7 @@ walkBackToTimeP = do

39branchTransactionP :: Parser TransactionGraphOperator

37branchTransactionP :: Parser TransactionGraphOperator

40branchTransactionP = do

38branchTransactionP = do

41 reservedOp ":branch"

39 reservedOp ":branch"

42− branchName <- identifier

40+ Branch <$> identifier

43− return $ Branch branchName

44

41

45deleteBranchP :: Parser TransactionGraphOperator

42deleteBranchP :: Parser TransactionGraphOperator

46deleteBranchP = do

43deleteBranchP = do

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

@@ -58,9 +58,7 @@ instance Hashable Atom where

58

59instance Binary UTCTime where

60 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)

61− get = do

62− r <- get :: Get Rational

61+ get = posixSecondsToUTCTime . fromRational <$> (get :: Get Rational)

63− return (posixSecondsToUTCTime (fromRational r))

64

62

65instance Binary Day where

63instance Binary Day where

66 put day = put $ toGregorian day

64 put day = put $ toGregorian day

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

@@ -37,9 +37,8 @@ atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType

37atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs

38

39mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation

40−mkRelationFromList attrs atomMatrix = do

40+mkRelationFromList attrs atomMatrix =

41− tupSet <- mkTupleSetFromList attrs atomMatrix

41+ Relation attrs <$> mkTupleSetFromList attrs atomMatrix

42− return $ Relation attrs tupSet

43

42

44emptyRelationWithAttrs :: Attributes -> Relation

43emptyRelationWithAttrs :: Attributes -> Relation

45emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet

44emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet

@@ -220,8 +219,7 @@ join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do

220 joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2

219 joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2

221 return $ joinedTupSet ++ accumulator

220 return $ joinedTupSet ++ accumulator

222 newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)

221 newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)

223− newTupSet <- mkTupleSet newAttrs newTupSetList

222+ Relation newAttrs <$> mkTupleSet newAttrs newTupSetList

224− return $ Relation newAttrs newTupSet

225

223

226-- | Difference takes two relations of the same type and returns a new relation which contains only tuples which appear in the first relation but not the second.

224-- | Difference takes two relations of the same type and returns a new relation which contains only tuples which appear in the first relation but not the second.

227difference :: Relation -> Relation -> Either RelationalError Relation

225difference :: Relation -> Relation -> Either RelationalError Relation

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

@@ -57,7 +57,7 @@ csvAsRelation attrs tConsMap inString = case APBL.parse (csvWithHeader csvDecode

57

58

59parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser (Either RelationalError Atom)

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

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

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

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

63parseCSVAtomP _ _ TextAtomType = do

src/lib/ProjectM36/Transaction/Persist.hs+8−9

@@ -23,9 +23,9 @@ import qualified Data.ByteString as BS

23import qualified Data.ByteString.Lazy as BSL

24

25getDirectoryNames :: FilePath -> IO [FilePath]

26−getDirectoryNames path = do

26+getDirectoryNames path =

27− subpaths <- getDirectoryContents path

28− return $ filter (\n -> n `notElem` ["..", "."]) subpaths

27+ filter (\ n -> n `notElem` ["..", "."]) <$> getDirectoryContents path

28+

29

30tempTransactionDir :: FilePath -> TransactionId -> FilePath

31tempTransactionDir dbdir transId = dbdir </> "." ++ show transId

@@ -109,10 +109,10 @@ readRelVars :: FilePath -> IO (M.Map RelVarName Relation)

109readRelVars transDir = do

110 let relvarsPath = relvarsDir transDir

111 relvarNames <- getDirectoryNames relvarsPath

112− relvars <- mapM (\name -> do

112+ let relvars = mapM (\name -> do

113 rel <- B.decode . decompress . BSL.fromStrict <$> BS.readFile (relvarsPath </> name)

114 return (T.pack name, rel)) relvarNames

115− return $ M.fromList relvars

115+ M.fromList <$> relvars

116

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

118writeAtomFuncs sync transDir funcs = do

@@ -191,8 +191,8 @@ readDBCFuncs transDir mScriptSession = do

191 funcNames <- getDirectoryNames (dbcFuncsDir transDir)

192 --only Haskell script functions can be serialized

193 --we always return the pre-compiled functions

194− funcs <- mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames

194+ let funcs = mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames

195− return $ HS.union basicDatabaseContextFunctions (HS.fromList funcs)

195+ HS.union basicDatabaseContextFunctions . HS.fromList <$> funcs

196

197readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction

198readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

@@ -232,8 +232,7 @@ readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)

232readIncDeps transDir = do

233 let incDepsPath = incDepsDir transDir

234 incDepNames <- getDirectoryNames incDepsPath

235− incDeps <- mapM (readIncDep transDir . T.pack) incDepNames

235+ M.fromList <$> mapM (readIncDep transDir . T.pack) incDepNames

236− return $ M.fromList incDeps

237

236

238readSubschemas :: FilePath -> IO Subschemas

237readSubschemas :: FilePath -> IO Subschemas

239readSubschemas transDir = do

238readSubschemas transDir = do

src/lib/ProjectM36/TransactionGraph.hs+5−6

@@ -98,9 +98,8 @@ transactionForId tid graph

98 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)

99

100transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)

101−transactionsForIds idSet graph = do

101+transactionsForIds idSet graph =

102− transList <- forM (S.toList idSet) (`transactionForId` graph)

102+ S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)

103− return (S.fromList transList)

104

103

105isRootTransaction :: Transaction -> TransactionGraph -> Bool

104isRootTransaction :: Transaction -> TransactionGraph -> Bool

106isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId

105isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId

@@ -108,9 +107,9 @@ isRootTransaction (Transaction _ MergeTransactionInfo{} _) _ = False

108

107

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

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

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

111−parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph = do

110+parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph =

112− trans <- transactionForId pId graph

111+ S.singleton <$> transactionForId pId graph

113− return (S.singleton trans)

112+

114

113

115parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph

114parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph

116

115

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

@@ -211,7 +211,5 @@ readGraphTransactionIdFile dbdir = do

211 (readUUID tid, readEpoch epochText, map readUUID parentIds)

212 readUUID uuidText = fromMaybe (error "failed to read uuid") (U.fromText uuidText)

213 readEpoch t = posixSecondsToUTCTime (realToFrac (either (error "failed to read epoch") fst (double t)))

214− --warning: uses lazy IO

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

216− return $ Right (map grapher $ T.lines graphTransactionIdData)

214+ Right . map grapher . T.lines <$> TIO.readFile (transactionLogPath dbdir)

217

215

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

@@ -56,9 +56,8 @@ atomTypeForAttributeName attrName tup = do

56-}

57

58atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> Either RelationalError (V.Vector Atom)

59−atomsForAttributeNames attrNames tuple = do

59+atomsForAttributeNames attrNames tuple =

60− vindices <- vectorIndicesForAttributeNames attrNames (tupleAttributes tuple)

61− return $ V.map (\index -> tupleAtoms tuple V.! index) vindices

60+ V.map (\index -> tupleAtoms tuple V.! index) <$> vectorIndicesForAttributeNames attrNames (tupleAttributes tuple)

62

61

63vectorIndicesForAttributeNames :: V.Vector AttributeName -> Attributes -> Either RelationalError (V.Vector Int)

62vectorIndicesForAttributeNames :: V.Vector AttributeName -> Attributes -> Either RelationalError (V.Vector Int)

64vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNames then

63vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNames then