f7681f6 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

move common stringy elements to Data.Text to save more space

f7681f6AgentM11 years ago

ProjectM36/Atom.hs+1

compare with master

unifiedsplit

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

1+{-# LANGUAGE OverloadedStrings #-}

1module ProjectM36.Atom where

2module ProjectM36.Atom where

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.Error

ProjectM36/Base.hs+19−13

@@ -11,8 +11,11 @@ import Control.DeepSeq.Generics (genericRnf)

11import GHC.Generics (Generic)

12import qualified Data.Vector as V

13import qualified Data.List as L

14+import qualified Data.Text as T

16+type StringType = T.Text

17+

15−data Atom = StringAtom String |

18+data Atom = StringAtom StringType |

16 IntAtom Int |

19 IntAtom Int |

17 RelationAtom Relation deriving (Show, Eq, Generic)

20 RelationAtom Relation deriving (Show, Eq, Generic)

@@ -26,8 +29,7 @@ data AtomType = StringAtomType |

27instance NFData AtomType where rnf = genericRnf

30instance NFData AtomType where rnf = genericRnf

29−type AttributeName = String

32+type AttributeName = T.Text

30−type AtomName = String

32data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)

34data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)

@@ -88,12 +90,14 @@ instance Hash.Hashable Relation where

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

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

89data RelationSizeInfinite = RelationSizeInfinite

91data RelationSizeInfinite = RelationSizeInfinite

93+type RelVarName = StringType

94+

91data RelationalExpr where

95data RelationalExpr where

92 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr

96 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr

93 --MakeFunctionalRelation (creates a relation from a tuple-generating function, potentially infinite)

97 --MakeFunctionalRelation (creates a relation from a tuple-generating function, potentially infinite)

94 --in Tutorial D, relational variables pick up the type of the first relation assigned to them

98 --in Tutorial D, relational variables pick up the type of the first relation assigned to them

95 --relational variables should also be able to be explicitly-typed like in Haskell

99 --relational variables should also be able to be explicitly-typed like in Haskell

96− RelationVariable :: String -> RelationalExpr

100+ RelationVariable :: RelVarName -> RelationalExpr

97 Project :: S.Set AttributeName -> RelationalExpr -> RelationalExpr

101 Project :: S.Set AttributeName -> RelationalExpr -> RelationalExpr

98 Union :: RelationalExpr -> RelationalExpr -> RelationalExpr

102 Union :: RelationalExpr -> RelationalExpr -> RelationalExpr

99 Join :: RelationalExpr -> RelationalExpr -> RelationalExpr

103 Join :: RelationalExpr -> RelationalExpr -> RelationalExpr

@@ -111,10 +115,12 @@ data RelationalExpr where

111

115

112data DatabaseContext = DatabaseContext {

116data DatabaseContext = DatabaseContext {

113 inclusionDependencies :: HS.HashSet InclusionDependency,

117 inclusionDependencies :: HS.HashSet InclusionDependency,

114− relationVariables :: M.Map String Relation

118+ relationVariables :: M.Map RelVarName Relation

115 } deriving (Show)

119 } deriving (Show)

116

120

121+type IncDepName = StringType

122+

117−data InclusionDependency = InclusionDependency String RelationalExpr RelationalExpr deriving (Show)

123+data InclusionDependency = InclusionDependency IncDepName RelationalExpr RelationalExpr deriving (Show)

118

124

119instance Hash.Hashable InclusionDependency where

125instance Hash.Hashable InclusionDependency where

120 hashWithSalt salt dep = Hash.hashWithSalt salt (show dep)

126 hashWithSalt salt dep = Hash.hashWithSalt salt (show dep)

@@ -124,12 +130,12 @@ instance Eq InclusionDependency where

124

130

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

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

126data DatabaseExpr where

132data DatabaseExpr where

127− Define :: String -> Attributes -> DatabaseExpr

133+ Define :: RelVarName -> Attributes -> DatabaseExpr

128− Undefine :: String -> DatabaseExpr --forget existence of relvar X

134+ Undefine :: RelVarName -> DatabaseExpr --forget existence of relvar X

129− Assign :: String -> RelationalExpr -> DatabaseExpr

135+ Assign :: RelVarName -> RelationalExpr -> DatabaseExpr

130− Insert :: String -> RelationalExpr -> DatabaseExpr

136+ Insert :: RelVarName -> RelationalExpr -> DatabaseExpr

131− Delete :: String -> RestrictionPredicateExpr -> DatabaseExpr

137+ Delete :: RelVarName -> RestrictionPredicateExpr -> DatabaseExpr

132− Update :: String -> M.Map String Atom -> RestrictionPredicateExpr -> DatabaseExpr -- needs restriction support

138+ Update :: RelVarName -> M.Map AttributeName Atom -> RestrictionPredicateExpr -> DatabaseExpr -- needs restriction support

133 AddInclusionDependency :: InclusionDependency -> DatabaseExpr

139 AddInclusionDependency :: InclusionDependency -> DatabaseExpr

134 MultipleExpr :: [DatabaseExpr] -> DatabaseExpr

140 MultipleExpr :: [DatabaseExpr] -> DatabaseExpr

135 deriving (Show,Eq)

141 deriving (Show,Eq)

@@ -147,7 +153,7 @@ data RestrictionPredicateExpr where

147

153

148-- child + parent links

154-- child + parent links

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

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

150−type HeadName = String

156+type HeadName = StringType

151

157

152type TransactionHeads = M.Map HeadName Transaction

158type TransactionHeads = M.Map HeadName Transaction

153

159

ProjectM36/Error.hs+7−6

@@ -5,21 +5,22 @@ import qualified Data.UUID as U

5import Control.DeepSeq (NFData, rnf)

6import Control.DeepSeq.Generics (genericRnf)

7import GHC.Generics (Generic)

8+import qualified Data.Text as T

10data RelationalError = NoSuchAttributeNameError AttributeName

11data RelationalError = NoSuchAttributeNameError AttributeName

11 | TupleAttributeCountMismatchError Int --attribute name

12 | TupleAttributeCountMismatchError Int --attribute name

12 | TupleAttributeTypeMismatchError Attributes

13 | TupleAttributeTypeMismatchError Attributes

13 | AttributeCountMismatchError Int

14 | AttributeCountMismatchError Int

14− | AttributeNameMismatchError String

15+ | AttributeNameMismatchError AttributeName

15 | AttributeNameInUseError AttributeName

16 | AttributeNameInUseError AttributeName

16 | AttributeIsNotRelationValuedError AttributeName

17 | AttributeIsNotRelationValuedError AttributeName

17− | RelVarNotDefinedError String

18+ | RelVarNotDefinedError RelVarName

18− | RelVarAlreadyDefinedError String

19+ | RelVarAlreadyDefinedError RelVarName

19 | RelVarAssignmentTypeMismatchError

20 | RelVarAssignmentTypeMismatchError

20− | InclusionDependencyCheckError String

21+ | InclusionDependencyCheckError IncDepName

21− | ParseError String

22+ | ParseError T.Text

22− | PredicateExpressionError String

23+ | PredicateExpressionError T.Text

23 | NoSuchTransactionError U.UUID

24 | NoSuchTransactionError U.UUID

24 | NoSuchHeadNameError HeadName

25 | NoSuchHeadNameError HeadName

25 | TransactionIsNotAHeadError U.UUID

26 | TransactionIsNotAHeadError U.UUID

ProjectM36/Relation.hs+4−3

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

1-- this is an implementation of the Relation typeclass which creates a GADT DSL

2−{-# LANGUAGE GADTs,ExistentialQuantification,NoImplicitPrelude #-}

2+{-# LANGUAGE GADTs,ExistentialQuantification,NoImplicitPrelude,OverloadedStrings #-}

3module ProjectM36.Relation where

4import qualified Data.Set as S

5import qualified Data.HashSet as HS

@@ -12,6 +12,7 @@ import qualified ProjectM36.Attribute as A

12import ProjectM36.TupleSet

13import ProjectM36.Error

14import Prelude hiding (join)

15+import qualified Data.Text as T

16attributes :: Relation -> Attributes

17attributes :: Relation -> Attributes

17attributes (Relation attrs _ ) = attrs

18attributes (Relation attrs _ ) = attrs

@@ -76,7 +77,7 @@ singletonValueFromRelation rel@(Relation _ tupSet) = if cardinality rel /= Count

76union :: Relation -> Relation -> Either RelationalError Relation

77union :: Relation -> Relation -> Either RelationalError Relation

77union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

78union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

78 if not (attrs1 == attrs2)

79 if not (attrs1 == attrs2)

79− then Left $ AttributeNameMismatchError (show attrs1 ++ show attrs2)

80+ then Left $ AttributeNameMismatchError (T.pack (show attrs1 ++ show attrs2))

80 else

81 else

81 Right $ Relation attrs1 newtuples

82 Right $ Relation attrs1 newtuples

82 where

83 where

@@ -259,7 +260,7 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe

259-- this is useful for performance and resource usage testing

260-- this is useful for performance and resource usage testing

260matrixRelation :: Int -> Int -> Either RelationalError Relation

261matrixRelation :: Int -> Int -> Either RelationalError Relation

261matrixRelation attributeCount tupleCount = do

262matrixRelation attributeCount tupleCount = do

262− let attrs = A.attributesFromList $ map (\c-> Attribute (show c) IntAtomType) [0 .. attributeCount-1]

263+ let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ show c) IntAtomType) [0 .. attributeCount-1]

263 tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))

264 tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))

264 tupleSet = HS.fromList $ map (\c -> tuple c) [0 .. tupleCount]

265 tupleSet = HS.fromList $ map (\c -> tuple c) [0 .. tupleCount]

265 mkRelation attrs tupleSet

266 mkRelation attrs tupleSet

ProjectM36/Relation/Show/HTML.hs+18−15

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

1+{-# LANGUAGE OverloadedStrings #-}

1module ProjectM36.Relation.Show.HTML where

2module ProjectM36.Relation.Show.HTML where

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Relation

4import ProjectM36.Relation

@@ -5,35 +6,37 @@ import ProjectM36.Tuple

5import qualified Data.HashSet as HS

6import qualified Data.HashSet as HS

6import qualified Data.List as L

7import qualified Data.List as L

7import ProjectM36.Attribute

8import ProjectM36.Attribute

9+import Data.Text (append, Text, pack)

10+import qualified Data.Text.IO as TIO

9−attributesAsHTML :: Attributes -> String

12+attributesAsHTML :: Attributes -> Text

10−attributesAsHTML attrs = "<tr>" ++ (foldr folder "" attrNameList) ++ "</tr>"

13+attributesAsHTML attrs = "<tr>" `append` (foldr folder "" attrNameList) `append` "</tr>"

11 where

14 where

12− folder attrName acc = acc ++ "<th>" ++ attrName ++ "</th>"

15+ folder attrName acc = acc `append` "<th>" `append` attrName `append` "</th>"

13 attrNameList = sortedAttributeNameList (attributeNameSet attrs)

16 attrNameList = sortedAttributeNameList (attributeNameSet attrs)

15−relationAsHTML :: Relation -> String

18+relationAsHTML :: Relation -> Text

16−relationAsHTML rel@(Relation attrNameSet tupleSet) = "<table border=\"1\">" ++ (attributesAsHTML attrNameSet) ++ (tupleSetAsHTML tupleSet) ++ "<tfoot>" ++ tablefooter ++ "</tfoot></table>"

19+relationAsHTML rel@(Relation attrNameSet tupleSet) = "<table border=\"1\">" `append` (attributesAsHTML attrNameSet) `append` (tupleSetAsHTML tupleSet) `append` "<tfoot>" `append` tablefooter `append` "</tfoot></table>"

17 where

20 where

18− tablefooter = "<tr><td colspan=\"100%\">" ++ show (cardinality rel) ++ " tuples</td></tr>"

21+ tablefooter = "<tr><td colspan=\"100%\">" `append` (pack $ show (cardinality rel)) `append` " tuples</td></tr>"

20−writeHTML :: String -> IO ()

23+writeHTML :: Text -> IO ()

21−writeHTML = writeFile "/home/agentm/rel.html"

24+writeHTML = TIO.writeFile "/home/agentm/rel.html"

23writeRel :: Relation -> IO ()

26writeRel :: Relation -> IO ()

24writeRel = writeHTML . relationAsHTML

27writeRel = writeHTML . relationAsHTML

26−atomAsHTML :: Atom -> String

29+atomAsHTML :: Atom -> Text

27atomAsHTML (StringAtom atom) = atom

30atomAsHTML (StringAtom atom) = atom

28−atomAsHTML (IntAtom int) = show int

31+atomAsHTML (IntAtom int) = pack (show int)

29atomAsHTML (RelationAtom rel) = relationAsHTML rel

32atomAsHTML (RelationAtom rel) = relationAsHTML rel

31−tupleAsHTML :: RelationTuple -> String

34+tupleAsHTML :: RelationTuple -> Text

32−tupleAsHTML tuple = "<tr>" ++ L.foldr folder "" (tupleSortedAssocs tuple) ++ "</tr>"

35+tupleAsHTML tuple = "<tr>" `append` L.foldr folder "" (tupleSortedAssocs tuple) `append` "</tr>"

33 where

36 where

34− folder tup acc = acc ++ "<td>" ++ (atomAsHTML (snd tup)) ++ "</td>"

37+ folder tup acc = acc `append` "<td>" `append` (atomAsHTML (snd tup)) `append` "</td>"

36−tupleSetAsHTML :: RelationTupleSet -> String

39+tupleSetAsHTML :: RelationTupleSet -> Text

37tupleSetAsHTML tupSet = HS.foldr folder "" tupSet

40tupleSetAsHTML tupSet = HS.foldr folder "" tupSet

38 where

41 where

39− folder tuple acc = acc ++ tupleAsHTML tuple

42+ folder tuple acc = acc `append` tupleAsHTML tuple

ProjectM36/Relation/Show/Term.hs+43−41

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

1+{-# LANGUAGE OverloadedStrings #-}

1--writes Relation to a String suitable for terminal output

2--writes Relation to a String suitable for terminal output

2module ProjectM36.Relation.Show.Term where

3module ProjectM36.Relation.Show.Term where

3import ProjectM36.Base

4import ProjectM36.Base

@@ -6,45 +7,46 @@ import ProjectM36.Relation

6import qualified Data.Set as S

7import qualified Data.Set as S

7import qualified Data.HashSet as HS

8import qualified Data.HashSet as HS

8import qualified Data.List as L

9import qualified Data.List as L

10+import qualified Data.Text as T

10−boxV :: String

12+boxV :: StringType

11boxV = "│"

13boxV = "│"

12−boxH :: String

14+boxH :: StringType

13boxH = "─"

15boxH = "─"

15−boxTL :: String

17+boxTL :: StringType

16boxTL = "┌"

18boxTL = "┌"

17−boxTR :: String

19+boxTR :: StringType

18boxTR = "┐"

20boxTR = "┐"

19−boxBL :: String

21+boxBL :: StringType

20boxBL = "└"

22boxBL = "└"

21−boxBR :: String

23+boxBR :: StringType

22boxBR = "┘"

24boxBR = "┘"

24−boxLB :: String

26+boxLB :: StringType

25boxLB = "├"

27boxLB = "├"

26−boxRB :: String

28+boxRB :: StringType

27boxRB = "┤"

29boxRB = "┤"

28−boxTB :: String

30+boxTB :: StringType

29boxTB = "┬"

31boxTB = "┬"

30−boxBB :: String

32+boxBB :: StringType

31boxBB = "┴"

33boxBB = "┴"

33−boxC :: String

35+boxC :: StringType

34boxC = "┼"

36boxC = "┼"

36−dboxH :: String

38+dboxH :: StringType

37dboxH = "═"

39dboxH = "═"

38−dboxL :: String

40+dboxL :: StringType

39dboxL = "╞"

41dboxL = "╞"

40−dboxR :: String

42+dboxR :: StringType

41dboxR = "╡"

43dboxR = "╡"

43class TermSize a where

45class TermSize a where

44 termLength :: a -> Int

46 termLength :: a -> Int

46--represent a relation as a table similar to those drawn by Date

48--represent a relation as a table similar to those drawn by Date

47−type Cell = String

49+type Cell = StringType

48type Table = ([Cell], [[Cell]]) --header, body

50type Table = ([Cell], [[Cell]]) --header, body

50addRow :: [Cell] -> Table -> Table

52addRow :: [Cell] -> Table -> Table

@@ -63,14 +65,14 @@ cellLocations tab@(header, _) = (maxWidths, maxHeights)

63 mergeMax a b = map (\(c,d) -> max c d) (zip a b)

65 mergeMax a b = map (\(c,d) -> max c d) (zip a b)

65--the normal "lines" function returns an empty list for an empty string which is not what we want

67--the normal "lines" function returns an empty list for an empty string which is not what we want

66−breakLines :: String -> [String]

68+breakLines :: StringType -> [StringType]

67breakLines "" = [""]

69breakLines "" = [""]

68−breakLines x = lines x

70+breakLines x = T.lines x

70cellSizes :: Table -> [([Int], [Int])]

72cellSizes :: Table -> [([Int], [Int])]

71cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . breakLines) row)) allRows

73cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . breakLines) row)) allRows

72 where

74 where

73− maxRowWidth row = L.maximumBy compare (map length (breakLines row))

75+ maxRowWidth row = L.maximumBy compare (map T.length (breakLines row))

74 allRows = [header] ++ body

76 allRows = [header] ++ body

76relationAsTable :: Relation -> Table

78relationAsTable :: Relation -> Table

@@ -85,53 +87,53 @@ relationAsTable rel@(Relation _ tupleSet) = (header, body)

85 Right atom -> showAtom atom

87 Right atom -> showAtom atom

86 ) oAttrs]

88 ) oAttrs]

88−showAtom :: Atom -> String

90+showAtom :: Atom -> StringType

89showAtom (StringAtom atom) = atom

91showAtom (StringAtom atom) = atom

90−showAtom (IntAtom atom) = show atom

92+showAtom (IntAtom atom) = T.pack $ show atom

91showAtom (RelationAtom rel) = renderTable $ relationAsTable rel

93showAtom (RelationAtom rel) = renderTable $ relationAsTable rel

93−renderTable :: Table -> String

95+renderTable :: Table -> StringType

94−renderTable table = renderHeader table (fst cellLocs) ++ renderBody (snd table) cellLocs

96+renderTable table = renderHeader table (fst cellLocs) `T.append` renderBody (snd table) cellLocs

95 where

97 where

96 cellLocs = cellLocations table

98 cellLocs = cellLocations table

98−renderHeader :: Table -> [Int] -> String

100+renderHeader :: Table -> [Int] -> StringType

99−renderHeader (header, body) columnLocations = renderTopBar ++ renderHeaderNames ++ renderBottomBar

101+renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHeaderNames `T.append` renderBottomBar

100 where

102 where

101− renderTopBar = boxTL ++ concat (L.intersperse boxTB (map (\x -> repeatString x boxH) columnLocations)) ++ boxTR ++ "\n"

103+ renderTopBar = boxTL `T.append` T.concat (L.intersperse boxTB (map (\x -> repeatString x boxH) columnLocations)) `T.append` boxTR `T.append` "\n"

102 renderHeaderNames = renderRow header columnLocations 1 boxV

104 renderHeaderNames = renderRow header columnLocations 1 boxV

103 renderBottomBar = if length body == 0 then ""

105 renderBottomBar = if length body == 0 then ""

104− else renderHBar boxLB boxC boxRB columnLocations ++ "\n"

106+ else renderHBar boxLB boxC boxRB columnLocations `T.append` "\n"

105

107

106−renderHBar :: String -> String -> String -> [Int] -> String

108+renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType

107−renderHBar left middle end columnLocations = left ++ concat (L.intersperse middle (map (\x -> repeatString x boxH) columnLocations)) ++ end

109+renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (\x -> repeatString x boxH) columnLocations)) `T.append` end

108

110

109−leftPaddedString :: Int -> Int -> String -> String

111+leftPaddedString :: Int -> Int -> StringType -> StringType

110leftPaddedString lineNum size str = paddedLines !! lineNum

112leftPaddedString lineNum size str = paddedLines !! lineNum

111 where

113 where

112− paddedLines = map (\line -> line ++ repeatString (size - length line) " ") (breakLines str ++ repeat "")

114+ paddedLines = map (\line -> line `T.append` repeatString (size - T.length line) " ") (breakLines str)

113

115

114−renderRow :: [Cell] -> [Int] -> Int -> String -> String

116+renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType

115−renderRow cells columnLocations rowHeight interspersed = unlines $ map renderOneLine [0..rowHeight-1]

117+renderRow cells columnLocations rowHeight interspersed = T.unlines $ map renderOneLine [0..rowHeight-1]

116 where

118 where

117− renderOneLine lineNum = boxV ++ concat (L.intersperse interspersed (map (\(size, value) -> leftPaddedString lineNum size value) (zip columnLocations cells))) ++ boxV

119+ renderOneLine lineNum = boxV `T.append` T.concat (L.intersperse interspersed (map (\(size, value) -> leftPaddedString lineNum size value) (zip columnLocations cells))) `T.append` boxV

118

120

119−renderBody :: [[Cell]] -> ([Int],[Int]) -> String

121+renderBody :: [[Cell]] -> ([Int],[Int]) -> StringType

120−renderBody cellMatrix cellLocations = renderRows ++ renderBottomBar

122+renderBody cellMatrix cellLocs = renderRows `T.append` renderBottomBar

121 where

123 where

122− columnLocations = fst cellLocations

124+ columnLocations = fst cellLocs

123− rowLocations = snd cellLocations

125+ rowLocations = snd cellLocs

124− renderRows = concat (map (\(row, rowHeight)-> renderRow row columnLocations rowHeight boxV) rowHeightMatrix)

126+ renderRows = T.concat (map (\(row, rowHeight)-> renderRow row columnLocations rowHeight boxV) rowHeightMatrix)

125 rowHeightMatrix = zip cellMatrix (tail rowLocations)

127 rowHeightMatrix = zip cellMatrix (tail rowLocations)

126 renderBottomBar = renderHBar boxBL boxBB boxBR columnLocations

128 renderBottomBar = renderHBar boxBL boxBB boxBR columnLocations

127

129

128orderedAttributeNames :: Relation -> [AttributeName]

130orderedAttributeNames :: Relation -> [AttributeName]

129orderedAttributeNames = S.toAscList . attributeNames

131orderedAttributeNames = S.toAscList . attributeNames

130

132

131−repeatString :: Int -> String -> String

133+repeatString :: Int -> StringType -> StringType

132−repeatString c s = concat (take c (repeat s))

134+repeatString c s = T.concat (take c (repeat s))

133

135

134−showRelation :: Relation -> String

136+showRelation :: Relation -> StringType

135showRelation rel

137showRelation rel

136 | rel == relationTrue = "true"

138 | rel == relationTrue = "true"

137 | rel == relationFalse = "false"

139 | rel == relationFalse = "false"

ProjectM36/RelationalExpression.hs+3−2

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

1+{-# LANGUAGE OverloadedStrings #-}

1module ProjectM36.RelationalExpression where

2module ProjectM36.RelationalExpression where

2import ProjectM36.Relation

3import ProjectM36.Relation

3import ProjectM36.Tuple

4import ProjectM36.Tuple

@@ -162,7 +163,7 @@ productsRel = case mkRelationFromList attrs matrix of

162 ]

163 ]

163

164

164--helper function to process relation variable creation/assignment

165--helper function to process relation variable creation/assignment

165−setRelVar :: String -> Relation -> DatabaseState (Maybe RelationalError)

166+setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)

166setRelVar relVarName rel = do

167setRelVar relVarName rel = do

167 currstate <- get

168 currstate <- get

168 let newRelVars = M.insert relVarName rel $ relationVariables currstate

169 let newRelVars = M.insert relVarName rel $ relationVariables currstate

@@ -173,7 +174,7 @@ setRelVar relVarName rel = do

173 return Nothing

174 return Nothing

174

175

175-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation

176-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation

176−deleteRelVar :: String -> DatabaseState (Maybe RelationalError)

177+deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)

177deleteRelVar relVarName = do

178deleteRelVar relVarName = do

178 currstate <- get

179 currstate <- get

179 let newRelVars = M.delete relVarName (relationVariables currstate)

180 let newRelVars = M.delete relVarName (relationVariables currstate)

ProjectM36/Transaction.hs+3−2

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

1+{-# LANGUAGE OverloadedStrings #-}

1module ProjectM36.Transaction where

2module ProjectM36.Transaction where

2import qualified Data.UUID as U

3import qualified Data.UUID as U

3import ProjectM36.Base

4import ProjectM36.Base

@@ -14,10 +15,10 @@ bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bo

14 freshTransaction = Transaction freshUUID (TransactionInfo U.nil S.empty) context

15 freshTransaction = Transaction freshUUID (TransactionInfo U.nil S.empty) context

15 bootstrapTransactions = S.singleton freshTransaction

16 bootstrapTransactions = S.singleton freshTransaction

17−transactionForHead :: String -> TransactionGraph -> Maybe Transaction

18+transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction

18transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads

19transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads

20−headNameForTransaction :: Transaction -> TransactionGraph -> Maybe String

21+headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName

21headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then

22headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then

22 Nothing

23 Nothing

23 else

24 else

ProjectM36/Transaction/Show.hs+4−2

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

1+{-# LANGUAGE OverloadedStrings #-}

1module ProjectM36.Transaction.Show where

2module ProjectM36.Transaction.Show where

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Relation

4import ProjectM36.Relation

@@ -9,6 +10,7 @@ import qualified ProjectM36.Attribute as A

9import qualified Data.HashSet as HS

10import qualified Data.HashSet as HS

10import qualified Data.Set as S

11import qualified Data.Set as S

11import qualified Data.Vector as V

12import qualified Data.Vector as V

13+import qualified Data.Text as T

13showTransactionStructure :: Transaction -> TransactionGraph -> String

15showTransactionStructure :: Transaction -> TransactionGraph -> String

14showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo

16showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo

@@ -37,7 +39,7 @@ graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _

37 parentAttributes = A.attributesFromList [Attribute "id" StringAtomType]

39 parentAttributes = A.attributesFromList [Attribute "id" StringAtomType]

38 tupleGenerator transaction = case transactionParentsRelation transaction graph of

40 tupleGenerator transaction = case transactionParentsRelation transaction graph of

39 Left err -> Left err

41 Left err -> Left err

40− Right parentTransRel -> Right [StringAtom $ show (transactionUUID transaction),

42+ Right parentTransRel -> Right [StringAtom $ T.pack $ show (transactionUUID transaction),

41 RelationAtom parentTransRel,

43 RelationAtom parentTransRel,

42 IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0,

44 IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0,

43 StringAtom $ case headNameForTransaction transaction graph of

45 StringAtom $ case headNameForTransaction transaction graph of

@@ -55,7 +57,7 @@ transactionParentsRelation trans graph = do

55 mkRelation attrs tupleSet

57 mkRelation attrs tupleSet

56 where

58 where

57 attrs = A.attributesFromList [Attribute "id" StringAtomType]

59 attrs = A.attributesFromList [Attribute "id" StringAtomType]

58− trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (StringAtom (show $ transactionUUID trans2))

60+ trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (StringAtom (T.pack (show $ transactionUUID trans2)))

ProjectM36/TupleSet.hs+2−1

@@ -19,7 +19,8 @@ singletonTupleSet = HS.singleton emptyTuple

19verifyTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError RelationTupleSet

20verifyTupleSet attrs tupleSet = do

21 --check that all tuples have the same attributes and that the atom types match

22− let tupleList = (map (verifyTuple attrs) (HS.toList tupleSet)) `P.using` P.parListChunk (100000 `div` 24) P.rdeepseq

22+ let tupleList = (map (verifyTuple attrs) (HS.toList tupleSet)) `P.using` P.parListChunk chunkSize P.rdeepseq

23+ chunkSize = HS.size tupleSet `div` 24

23 --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet)

24 --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet)

24 if length (lefts tupleList) > 0 then

25 if length (lefts tupleList) > 0 then

25 Left $ head (lefts tupleList)

26 Left $ head (lefts tupleList)

TutorialD/Interpreter.hs+50−45

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

1−{-# LANGUAGE GADTs #-}

1+{-# LANGUAGE GADTs,OverloadedStrings #-}

2module TutorialD.Interpreter where

3import ProjectM36.Base

4import ProjectM36.Relation

@@ -29,6 +29,8 @@ import System.Directory (getHomeDirectory)

29import qualified Data.UUID as U

30import Data.UUID.V4 (nextRandom)

31import qualified Data.Vector as V

32+import qualified Data.Text as T

33+import qualified Data.Text.IO as TIO

33{-

35{-

34List of Tutorial D operators:

36List of Tutorial D operators:

@@ -70,7 +72,9 @@ uuidP = do

71--used in projection

73--used in projection

72attributeList :: Parser [AttributeName]

74attributeList :: Parser [AttributeName]

75+attributeList = do

73−attributeList = sepBy identifier comma

76+ attrs <- sepBy identifier comma

77+ return $ map T.pack attrs

75makeRelation :: Parser RelationalExpr

79makeRelation :: Parser RelationalExpr

76makeRelation = do

80makeRelation = do

@@ -94,7 +98,7 @@ attributeAndType = do

94 attrTypeName <- identifier

98 attrTypeName <- identifier

95 --convert type name into type

99 --convert type name into type

96 case tutDTypeToAtomType attrTypeName of

100 case tutDTypeToAtomType attrTypeName of

97− Just t -> return $ Attribute attrName t

101+ Just t -> return $ Attribute (T.pack attrName) t

98 Nothing -> fail (attrTypeName ++ " is not a valid type name.")

102 Nothing -> fail (attrTypeName ++ " is not a valid type name.")

103

100tupleP :: Parser RelationTuple

104tupleP :: Parser RelationTuple

@@ -113,7 +117,7 @@ tupleAtomP = do

113 case tutDTypeToAtomType attrType of

117 case tutDTypeToAtomType attrType of

114 Nothing -> fail (attrType ++ " is not a valid type name.")

118 Nothing -> fail (attrType ++ " is not a valid type name.")

115 Just typeA -> if typeA == atomTypeForAtom atom then

119 Just typeA -> if typeA == atomTypeForAtom atom then

116− return $ (attributeName, atom)

120+ return $ (T.pack attributeName, atom)

117 else

121 else

118 fail "type mismatch in tuple generation"

122 fail "type mismatch in tuple generation"

119

123

@@ -132,7 +136,7 @@ atomTypeToTutDType atomType = case atomType of

132 _ -> Nothing

136 _ -> Nothing

133

137

134relVarP :: Parser RelationalExpr

138relVarP :: Parser RelationalExpr

135−relVarP = liftA RelationVariable identifier

139+relVarP = liftA (RelationVariable . T.pack) identifier

136

140

137relTerm = parens relExpr

141relTerm = parens relExpr

138 <|> makeRelation

142 <|> makeRelation

@@ -149,7 +153,7 @@ assignP = do

149 reservedOp ":="

153 reservedOp ":="

150 return relVarName

154 return relVarName

151 expr <- relExpr

155 expr <- relExpr

152− return $ Assign relVarName expr

156+ return $ Assign (T.pack relVarName) expr

153

157

154renameClause = do

158renameClause = do

155 oldAttr <- identifier

159 oldAttr <- identifier

@@ -161,7 +165,7 @@ renameP :: Parser (RelationalExpr -> RelationalExpr)

161renameP = do

165renameP = do

162 reservedOp "rename"

166 reservedOp "rename"

163 (oldAttr, newAttr) <- braces renameClause

167 (oldAttr, newAttr) <- braces renameClause

164− return $ Rename oldAttr newAttr

168+ return $ Rename (T.pack oldAttr) (T.pack newAttr)

165

169

166whereClauseP = do

170whereClauseP = do

167 reservedOp "where"

171 reservedOp "where"

@@ -178,14 +182,14 @@ groupP :: Parser (RelationalExpr -> RelationalExpr)

178groupP = do

182groupP = do

179 reservedOp "group"

183 reservedOp "group"

180 (groupAttrList, groupAttrName) <- parens groupClause

184 (groupAttrList, groupAttrName) <- parens groupClause

181− return $ Group (S.fromList groupAttrList) groupAttrName

185+ return $ Group (S.fromList groupAttrList) (T.pack groupAttrName)

182

186

183--in "Time and Relational Theory" (2014), Date's Tutorial D grammar for ungroup takes one attribute, while in previous books, it take multiple arguments. Let us assume that nested ungroups are the same as multiple attributes.

187--in "Time and Relational Theory" (2014), Date's Tutorial D grammar for ungroup takes one attribute, while in previous books, it take multiple arguments. Let us assume that nested ungroups are the same as multiple attributes.

184ungroupP :: Parser (RelationalExpr -> RelationalExpr)

188ungroupP :: Parser (RelationalExpr -> RelationalExpr)

185ungroupP = do

189ungroupP = do

186 reservedOp "ungroup"

190 reservedOp "ungroup"

187 rvaAttrName <- identifier

191 rvaAttrName <- identifier

188− return $ Ungroup rvaAttrName

192+ return $ Ungroup (T.pack rvaAttrName)

189

193

190relOperators = [

194relOperators = [

191 [Postfix projectOp],

195 [Postfix projectOp],

@@ -220,7 +224,7 @@ insertP = do

220 reservedOp "insert"

224 reservedOp "insert"

221 relvar <- identifier

225 relvar <- identifier

222 expr <- relExpr

226 expr <- relExpr

223− return $ Insert relvar expr

227+ return $ Insert (T.pack relvar) expr

224

228

225defineP :: Parser DatabaseExpr

229defineP :: Parser DatabaseExpr

226defineP = do

230defineP = do

@@ -229,20 +233,20 @@ defineP = do

229 reservedOp "::"

233 reservedOp "::"

230 return relVarName

234 return relVarName

231 attributeSet <- makeAttributes

235 attributeSet <- makeAttributes

232− return $ Define relVarName attributeSet

236+ return $ Define (T.pack relVarName) attributeSet

233

237

234undefineP :: Parser DatabaseExpr

238undefineP :: Parser DatabaseExpr

235undefineP = do

239undefineP = do

236 reservedOp "undefine"

240 reservedOp "undefine"

237 relVarName <- identifier

241 relVarName <- identifier

238− return $ Undefine relVarName

242+ return $ Undefine (T.pack relVarName)

239

243

240deleteP :: Parser DatabaseExpr

244deleteP :: Parser DatabaseExpr

241deleteP = do

245deleteP = do

242 reservedOp "delete"

246 reservedOp "delete"

243 relVarName <- identifier

247 relVarName <- identifier

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

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

245− return $ Delete relVarName predicate

249+ return $ Delete (T.pack relVarName) predicate

246

250

247updateP :: Parser DatabaseExpr

251updateP :: Parser DatabaseExpr

248updateP = do

252updateP = do

@@ -250,7 +254,7 @@ updateP = do

250 relVarName <- identifier

254 relVarName <- identifier

251 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)

255 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)

252 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)

256 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)

253− return $ Update relVarName attributeAssignments predicate

257+ return $ Update (T.pack relVarName) (M.mapKeys T.pack $ attributeAssignments) predicate

254

258

255constraintP :: Parser DatabaseExpr

259constraintP :: Parser DatabaseExpr

256constraintP = do

260constraintP = do

@@ -259,7 +263,7 @@ constraintP = do

259 subset <- relExpr

263 subset <- relExpr

260 reservedOp "in"

264 reservedOp "in"

261 superset <- relExpr

265 superset <- relExpr

262− return $ AddInclusionDependency (InclusionDependency constraintName subset superset)

266+ return $ AddInclusionDependency (InclusionDependency (T.pack constraintName) subset superset)

263

267

264attributeAssignment :: Parser (String, Atom)

268attributeAssignment :: Parser (String, Atom)

265attributeAssignment = do

269attributeAssignment = do

@@ -270,21 +274,21 @@ attributeAssignment = do

270

274

271parseString :: String -> Either RelationalError DatabaseExpr

275parseString :: String -> Either RelationalError DatabaseExpr

272parseString str = case parse (multipleDatabaseExpr <* eof) "" str of

276parseString str = case parse (multipleDatabaseExpr <* eof) "" str of

273− Left err -> Left $ ParseError (show err)

277+ Left err -> Left $ ParseError (T.pack (show err))

274 Right r -> Right r

278 Right r -> Right r

275

279

276--operators which only rely on database context reading

280--operators which only rely on database context reading

277data ContextOperator where

281data ContextOperator where

278 ShowRelation :: RelationalExpr -> ContextOperator

282 ShowRelation :: RelationalExpr -> ContextOperator

279 ShowRelationType :: RelationalExpr -> ContextOperator

283 ShowRelationType :: RelationalExpr -> ContextOperator

280− ShowConstraint :: String -> ContextOperator

284+ ShowConstraint :: StringType -> ContextOperator

281 ShowPlan :: DatabaseExpr -> ContextOperator

285 ShowPlan :: DatabaseExpr -> ContextOperator

282 Quit :: ContextOperator

286 Quit :: ContextOperator

283 deriving (Show)

287 deriving (Show)

284

288

285--operators which manipulate a transaction graph

289--operators which manipulate a transaction graph

286data GraphOperator where

290data GraphOperator where

287− JumpToHead :: String -> GraphOperator

291+ JumpToHead :: HeadName -> GraphOperator

288 JumpToTransaction :: U.UUID -> GraphOperator

292 JumpToTransaction :: U.UUID -> GraphOperator

289 Branch :: HeadName -> GraphOperator

293 Branch :: HeadName -> GraphOperator

290 Commit :: GraphOperator

294 Commit :: GraphOperator

@@ -318,13 +322,13 @@ showConstraintsP :: Parser ContextOperator

318showConstraintsP = do

322showConstraintsP = do

319 reservedOp ":constraints"

323 reservedOp ":constraints"

320 constraintName <- option "" identifier

324 constraintName <- option "" identifier

321− return $ ShowConstraint constraintName

325+ return $ ShowConstraint (T.pack constraintName)

322

326

323jumpToHeadP :: Parser GraphOperator

327jumpToHeadP :: Parser GraphOperator

324jumpToHeadP = do

328jumpToHeadP = do

325 reservedOp ":jumphead"

329 reservedOp ":jumphead"

326 headid <- identifier

330 headid <- identifier

327− return $ JumpToHead headid

331+ return $ JumpToHead (T.pack headid)

328

332

329jumpToTransactionP :: Parser GraphOperator

333jumpToTransactionP :: Parser GraphOperator

330jumpToTransactionP = do

334jumpToTransactionP = do

@@ -336,7 +340,7 @@ branchTransactionP :: Parser GraphOperator

336branchTransactionP = do

340branchTransactionP = do

337 reservedOp ":branch"

341 reservedOp ":branch"

338 branchName <- identifier

342 branchName <- identifier

339− return $ Branch branchName

343+ return $ Branch (T.pack branchName)

340

344

341commitTransactionP :: Parser GraphOperator

345commitTransactionP :: Parser GraphOperator

342commitTransactionP = do

346commitTransactionP = do

@@ -372,32 +376,32 @@ contextOps = typeP

372interpreterOps :: Parser (Either ContextOperator GraphOperator)

376interpreterOps :: Parser (Either ContextOperator GraphOperator)

373interpreterOps = liftM Left contextOps <|> liftM Right transactionGraphOps

377interpreterOps = liftM Left contextOps <|> liftM Right transactionGraphOps

374

378

375−showRelationAttributes :: Relation -> String

379+showRelationAttributes :: Relation -> T.Text

376−showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"

380+showRelationAttributes rel = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrs) `T.append` "}"

377 where

381 where

378− showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of

382+ showAttribute (Attribute name atomType) = name `T.append` " " `T.append` case atomTypeToTutDType atomType of

379− Just t -> show t

383+ Just t -> T.pack (show t)

380− Nothing -> "unknown"

384+ Nothing -> T.pack "unknown"

381 attrs = V.toList $ attributes rel

385 attrs = V.toList $ attributes rel

382

386

383data TutorialDOperatorResult = QuitResult |

387data TutorialDOperatorResult = QuitResult |

384− DisplayResult String |

388+ DisplayResult StringType |

385− DisplayErrorResult String |

389+ DisplayErrorResult StringType |

386 QuietSuccessResult |

390 QuietSuccessResult |

387 NoActionResult --refactor to make this dead- there should be only one parser

391 NoActionResult --refactor to make this dead- there should be only one parser

388

392

389evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult

393evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult

390evalContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of

394evalContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of

391 (Right rel, _) -> DisplayResult $ showRelationAttributes rel

395 (Right rel, _) -> DisplayResult $ showRelationAttributes rel

392− (Left err, _) -> DisplayErrorResult $ show err

396+ (Left err, _) -> DisplayErrorResult $ T.pack (show err)

393

397

394evalContextOp context (ShowRelation expr) = do

398evalContextOp context (ShowRelation expr) = do

395 case runState (evalRelationalExpr expr) context of

399 case runState (evalRelationalExpr expr) context of

396− (Left err, _) -> DisplayErrorResult $ show err

400+ (Left err, _) -> DisplayErrorResult $ T.pack (show err)

397 (Right rel, _) -> DisplayResult $ showRelation rel

401 (Right rel, _) -> DisplayResult $ showRelation rel

398

402

399evalContextOp context (ShowConstraint name) = do

403evalContextOp context (ShowConstraint name) = do

400− DisplayResult $ show filteredDeps

404+ DisplayResult $ T.pack (show filteredDeps)

401 where

405 where

402 deps = inclusionDependencies context

406 deps = inclusionDependencies context

403 filteredDeps = case name of

407 filteredDeps = case name of

@@ -405,7 +409,7 @@ evalContextOp context (ShowConstraint name) = do

405 name2 -> HS.filter (\(InclusionDependency n _ _) -> n == name2) deps

409 name2 -> HS.filter (\(InclusionDependency n _ _) -> n == name2) deps

406

410

407evalContextOp context (ShowPlan dbExpr) = do

411evalContextOp context (ShowPlan dbExpr) = do

408− DisplayResult $ show plan

412+ DisplayResult $ T.pack (show plan)

409 where

413 where

410 plan = evalState (applyStaticDatabaseOptimization dbExpr) context

414 plan = evalState (applyStaticDatabaseOptimization dbExpr) context

411

415

@@ -500,20 +504,20 @@ interpretNO context tutdstring = case parseString tutdstring of

500-- for interpreter-specific operations

504-- for interpreter-specific operations

501interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)

505interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)

502interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of

506interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of

503− Left err -> (trans, transGraph, NoActionResult)

507+ Left _ -> (trans, transGraph, NoActionResult)

504 Right ops -> case ops of

508 Right ops -> case ops of

505 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))

509 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))

506 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of

510 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of

507− Left err -> (trans, transGraph, DisplayErrorResult $ show err)

511+ Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))

508 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)

512 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)

509

513

510−promptText :: DisconnectedTransaction -> TransactionGraph -> String

514+promptText :: DisconnectedTransaction -> TransactionGraph -> StringType

511−promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "

515+promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "

512 where

516 where

513 transInfo = case transactionForUUID parentUUID graph of

517 transInfo = case transactionForUUID parentUUID graph of

514 Left _ -> "unknown"

518 Left _ -> "unknown"

515 Right parentTrans -> case headNameForTransaction parentTrans graph of

519 Right parentTrans -> case headNameForTransaction parentTrans graph of

516− Nothing -> show $ transactionUUID parentTrans

520+ Nothing -> T.pack (show $ transactionUUID parentTrans)

517 Just headName -> headName

521 Just headName -> headName

518

522

519reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()

523reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()

@@ -521,7 +525,7 @@ reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentCo

521 homeDirectory <- getHomeDirectory

525 homeDirectory <- getHomeDirectory

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

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

523

527

524− maybeLine <- runInputT settings $ getInputLine (promptText currentTransaction graph)

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

525

529

526 let roloop = reprLoop currentTransaction graph

530 let roloop = reprLoop currentTransaction graph

527 case maybeLine of

531 case maybeLine of

@@ -530,12 +534,12 @@ reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentCo

530 newUUID <- nextRandom

534 newUUID <- nextRandom

531 case interpretOps newUUID currentTransaction graph line of

535 case interpretOps newUUID currentTransaction graph line of

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

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

533− (_, _, DisplayErrorResult err) -> hPutStrLn stderr ("ERR: " ++ err) >> roloop

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

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

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

535− putStrLn out

539+ TIO.putStrLn out

536 reprLoop updatedTrans updatedGraph

540 reprLoop updatedTrans updatedGraph

537 (updatedTrans, updatedGraph, QuietSuccessResult) -> do

541 (updatedTrans, updatedGraph, QuietSuccessResult) -> do

538− putStrLn "Done."

542+ TIO.putStrLn "Done."

539 reprLoop updatedTrans updatedGraph

543 reprLoop updatedTrans updatedGraph

540 (_, _, NoActionResult) -> do

544 (_, _, NoActionResult) -> do

541 let (value, contextup) = interpret currentContext line

545 let (value, contextup) = interpret currentContext line

@@ -543,7 +547,7 @@ reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentCo

543 case value of

547 case value of

544 Nothing -> reprLoop updatedTransaction graph

548 Nothing -> reprLoop updatedTransaction graph

545 Just err -> do

549 Just err -> do

546− hPutStrLn stderr ("ERR:" ++ show err)

550+ TIO.hPutStrLn stderr ("ERR:" `T.append` T.pack (show err))

547 reprLoop currentTransaction graph

551 reprLoop currentTransaction graph

548

552

549restrictionPredicateP :: Parser RestrictionPredicateExpr

553restrictionPredicateP :: Parser RestrictionPredicateExpr

@@ -569,18 +573,19 @@ restrictionAttributeEqualityP = do

569 attributeName <- identifier

573 attributeName <- identifier

570 reservedOp "="

574 reservedOp "="

571 atom <- stringAtomP <|> intAtomP

575 atom <- stringAtomP <|> intAtomP

572− return $ AttributeEqualityPredicate attributeName atom

576+ return $ AttributeEqualityPredicate (T.pack attributeName) atom

573

577

574quotedChar = noneOf "\""

578quotedChar = noneOf "\""

575 <|> try (string "\"\"" >> return '"')

579 <|> try (string "\"\"" >> return '"')

576

580

577−stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")

581+stringAtomP = liftA (StringAtom . T.pack) (string "\"" *> many quotedChar <* string "\"")

578

582

579intAtomP = do

583intAtomP = do

580 intstr <- many digit

584 intstr <- many digit

581 return $ IntAtom (read intstr)

585 return $ IntAtom (read intstr)

582

586

583--used by :dumpGraph

587--used by :dumpGraph

588+{-

584displayTransactionGraph :: TransactionGraph -> String

589displayTransactionGraph :: TransactionGraph -> String

585displayTransactionGraph (TransactionGraph _ transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet

590displayTransactionGraph (TransactionGraph _ transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet

586−

591+-}

TutorialD/tutd.hs+1

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

1+{-# LANGUAGE OverloadedStrings #-}

1import TutorialD.Interpreter

2import TutorialD.Interpreter

2import ProjectM36.RelationalExpression

3import ProjectM36.RelationalExpression

3import ProjectM36.Transaction

4import ProjectM36.Transaction

benchmark/bigrel.hs+26−10

@@ -1,37 +1,52 @@

1−{-# LANGUAGE FlexibleInstances #-}

1+{-# LANGUAGE FlexibleInstances,OverloadedStrings #-}

2import ProjectM36.Base

3import ProjectM36.Relation

4import ProjectM36.Tuple

5−import ProjectM36.Error

6import ProjectM36.Relation.Show.CSV

5import ProjectM36.Relation.Show.CSV

7−import qualified Data.Map as M

8import qualified Data.HashSet as HS

6import qualified Data.HashSet as HS

9import qualified Data.ByteString.Lazy.Char8 as BS

7import qualified Data.ByteString.Lazy.Char8 as BS

10import qualified Data.IntMap as IM

8import qualified Data.IntMap as IM

11import qualified Data.Hashable as Hash

9import qualified Data.Hashable as Hash

12import qualified Data.Vector as V

10import qualified Data.Vector as V

13−import Control.DeepSeq

11+import Options.Applicative

15dumpcsv :: Relation -> IO ()

13dumpcsv :: Relation -> IO ()

16dumpcsv = BS.putStrLn . relationAsCSV

14dumpcsv = BS.putStrLn . relationAsCSV

16+parseAttributeCount :: Parser Int

17+parseAttributeCount = option auto (short 'a' <> long "attribute-count")

18+

19+parseTupleCount :: Parser Int

20+parseTupleCount = option auto (short 't' <> long "tuple-count")

21+

22+parseArgs :: Parser (Int, Int)

23+parseArgs = (,) <$> parseAttributeCount <*> parseTupleCount

24+

25+

18−main = matrixRun

26+main :: IO ()

27+main = do

28+ (attributeCount, tupleCount) <- execParser $ info (helper <*> parseArgs) fullDesc

29+ --matrixRestrictRun

30+ matrixRun attributeCount tupleCount

19− --vectorMatrixRun

31+ --vectorMatrixRun

20− --intmapMatrixRun

32+ --intmapMatrixRun

22-- takes 30 minutes to run and 1.1 GB

34-- takes 30 minutes to run and 1.1 GB

35+matrixRestrictRun :: IO ()

23matrixRestrictRun = do

36matrixRestrictRun = do

24− case matrixRelation 100 100000 of

37+ case matrixRelation 100 1000000 of

25 Left err -> putStrLn (show err)

38 Left err -> putStrLn (show err)

26 Right rel -> case restrict (\tuple -> atomForAttributeName "0" tuple == Right (IntAtom 5)) rel of

39 Right rel -> case restrict (\tuple -> atomForAttributeName "0" tuple == Right (IntAtom 5)) rel of

27 Left err -> putStrLn (show err)

40 Left err -> putStrLn (show err)

28 Right rel -> dumpcsv rel

41 Right rel -> dumpcsv rel

30−matrixRun = do

43+matrixRun :: Int -> Int -> IO ()

44+matrixRun attributeCount tupleCount= do

31− case matrixRelation 100 100000 of

45+ case matrixRelation attributeCount tupleCount of

32 Left err -> putStrLn (show err)

46 Left err -> putStrLn (show err)

33 Right rel -> putStrLn "Done"

47 Right rel -> putStrLn "Done"

49+intmapMatrixRun :: IO ()

35intmapMatrixRun = do

50intmapMatrixRun = do

36 let matrix = intmapMatrixRelation 100 100000

51 let matrix = intmapMatrixRelation 100 100000

37 putStrLn (show matrix)

52 putStrLn (show matrix)

@@ -46,6 +61,7 @@ intmapMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tu

46instance Hash.Hashable (IM.IntMap Atom) where

61instance Hash.Hashable (IM.IntMap Atom) where

47 hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)

62 hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)

64+vectorMatrixRun :: IO ()

49vectorMatrixRun = do

65vectorMatrixRun = do

50 let matrix = vectorMatrixRelation 100 100000

66 let matrix = vectorMatrixRelation 100 100000

51 putStrLn (show matrix)

67 putStrLn (show matrix)

project-m36.cabal+2−2

@@ -33,7 +33,7 @@ Executable tutd

33 GHC-Options: -Wall

35Executable bigrel

36− Build-Depends: base,deepseq

36+ Build-Depends: base,deepseq,optparse-applicative

37 Other-Modules: ProjectM36.Base,

38 ProjectM36.Relation

39 ProjectM36.Tuple,

@@ -41,7 +41,7 @@ Executable bigrel

41 ProjectM36.Relation.Show.CSV

42 main-is: benchmark/bigrel.hs

43 GHC-Options: -Wall -threaded -rtsopts

44− GHC-Prof-Options: -fprof-auto "-with-rtsopts -p -s -h -i0.1"

44+ GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

46Test-Suite test-tutoriald

47 type: exitcode-stdio-1.0

test/Relation/Basic.hs+2−1

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

1+{-# LANGUAGE OverloadedStrings #-}

1import Test.HUnit

2import Test.HUnit

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Relation

4import ProjectM36.Relation

@@ -70,7 +71,7 @@ testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRe

70--mkRelation tests

71--mkRelation tests

71--test tupleset key mismatch failure

72--test tupleset key mismatch failure

72testMkRelation1 :: Test

73testMkRelation1 :: Test

73−testMkRelation1 = TestCase $ assertEqual "key mismatch" (Left $ TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "a" StringAtomType])) (mkRelation testAttrs testTupSet)

74+testMkRelation1 = TestCase $ assertEqual "key mismatch" (Left $ TupleAttributeTypeMismatchError A.emptyAttributes) (mkRelation testAttrs testTupSet) -- the error attribute set is empty due to an optimization- the tuple attrs do not match the atoms' types

74 where

75 where

75 testAttrs = A.attributesFromList [Attribute "a" StringAtomType]

76 testAttrs = A.attributesFromList [Attribute "a" StringAtomType]

76 testTupSet = HS.fromList [mkRelationTuple testAttrs $ V.fromList [StringAtom "v"],

77 testTupSet = HS.fromList [mkRelationTuple testAttrs $ V.fromList [StringAtom "v"],

test/Relation/StaticOptimizer.hs+1

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

1+{-# LANGUAGE OverloadedStrings #-}

1import ProjectM36.Base

2import ProjectM36.Base

2import ProjectM36.Relation

3import ProjectM36.Relation

3import ProjectM36.RelationalExpression

4import ProjectM36.RelationalExpression

test/TutorialD/Interpreter.hs+1

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

1+{-# LANGUAGE OverloadedStrings #-}

1import TutorialD.Interpreter

2import TutorialD.Interpreter

2import Test.HUnit

3import Test.HUnit

3import ProjectM36.RelationalExpression

4import ProjectM36.RelationalExpression