da70d10 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP attributes + hashset version and accessors refactoring

da70d10AgentM6 years ago

project-m36.cabal+12

compare with master

unifiedsplit

@@ -281,6 +281,18 @@ Benchmark basic-benchmark

281 if flag(profiler)

282 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

283

284+--benchmark inserts, updates, deletes for a basic use-case to shake out any space leaks

285+Benchmark update-exprs

286+ Default-Language: Haskell2010

287+ Default-Extensions: OverloadedStrings

288+ Build-Depends: base, criterion, project-m36, text, winery

289+ Main-Is: benchmark/Server.hs

290+ Type: exitcode-stdio-1.0

291+ GHC-Options: -Wall -threaded -rtsopts

292+ HS-Source-Dirs: ./src/bin

293+ if flag(profiler)

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

295+

284Test-Suite test-tutoriald

296Test-Suite test-tutoriald

285 import: commontest

297 import: commontest

286 type: exitcode-stdio-1.0

298 type: exitcode-stdio-1.0

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+14−2

@@ -11,6 +11,7 @@ import ProjectM36.Error

11import ProjectM36.IsomorphicSchema

12import ProjectM36.Server.RemoteCallTypes

13import ProjectM36.MerkleHash

14+import ProjectM36.Attribute as A

15import Data.Aeson

16import Data.Aeson

16import Data.ByteString.Base64 as B64

17import Data.ByteString.Base64 as B64

@@ -44,8 +45,11 @@ instance FromJSON ExecuteRelationalExpr

44instance ToJSON Relation

45instance ToJSON Relation

45instance FromJSON Relation

46instance FromJSON Relation

47−instance ToJSON Attribute

48+instance ToJSON Attribute where

49+ toJSON (Attribute attrName aType) = object [ "name" .= attrName

50+ , "type" .= toJSON aType ]

48−instance FromJSON Attribute

51+instance FromJSON Attribute where

52+ parseJSON = withObject "Attribute" $ \v -> Attribute <$> v .: "name" <*> v .: "type"

50instance ToJSON ExtendTupleExpr

54instance ToJSON ExtendTupleExpr

51instance FromJSON ExtendTupleExpr

55instance FromJSON ExtendTupleExpr

@@ -145,6 +149,12 @@ instance FromJSON MerkleHash where

145 Left err -> fail ("Failed to parse merkle hash: " ++ err)

149 Left err -> fail ("Failed to parse merkle hash: " ++ err)

146 Right bs -> pure (MerkleHash bs)

150 Right bs -> pure (MerkleHash bs)

147

151

152+instance ToJSON Attributes where

153+ toJSON attrs = object ["attributes" .= map toJSON (A.toList attrs)]

154+instance FromJSON Attributes where

155+ parseJSON = withObject "Attributes" $ \o ->

156+ A.attributesFromList <$> o .: "attributes"

157+

148instance ToJSON RelationalError

158instance ToJSON RelationalError

149instance FromJSON RelationalError

159instance FromJSON RelationalError

150

160

@@ -168,3 +178,5 @@ instance FromJSON AtomFunctionError

168

178

169instance ToJSON WithNameExpr

179instance ToJSON WithNameExpr

170instance FromJSON WithNameExpr

180instance FromJSON WithNameExpr

181+

182+

src/bin/TutorialD/Interpreter/Base.hs+3−3

@@ -12,6 +12,7 @@ module TutorialD.Interpreter.Base (

12 where

13import ProjectM36.Base

14import ProjectM36.AtomType

15+import ProjectM36.Attribute as A

15import ProjectM36.Relation

16import ProjectM36.Relation

16import ProjectM36.DataFrame

17import ProjectM36.DataFrame

@@ -30,7 +31,6 @@ import Data.Text hiding (count)

30import System.Random

31import System.Random

31import qualified Data.Text as T

32import qualified Data.Text as T

32import qualified Data.List as L

33import qualified Data.List as L

33−import qualified Data.Vector as V

34import qualified Data.Text.IO as TIO

35import System.IO

36import ProjectM36.Relation.Show.Term

@@ -163,8 +163,8 @@ uncapitalizedIdentifier =

163showRelationAttributes :: Attributes -> Text

164showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"

165 where

166− showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType

166+ showAttribute (Attribute name atomType') = name <> " " <> prettyAtomType atomType'

167− attrsL = V.toList attrs

167+ attrsL = A.toList attrs

168

169type PromptLength = Int

170

src/bin/TutorialD/Printer.hs+6−6

@@ -5,7 +5,7 @@

5{-# LANGUAGE TypeApplications #-}

6module TutorialD.Printer where

7import ProjectM36.Base

8−import ProjectM36.Attribute hiding (null)

8+import ProjectM36.Attribute as A hiding (null)

9import Data.Text.Prettyprint.Doc

10import qualified Data.Set as S hiding (fromList)

11import qualified Data.Vector as V

@@ -60,9 +60,9 @@ instance Pretty RelationTuple where

60 pretty (RelationTuple attrs atoms) = "tuple" <> bracesList (zipWith (\x y-> pretty x <+> pretty y) (V.toList (attributeNames attrs)) (V.toList atoms))

62instance Pretty Relation where

63− pretty (Relation attrs tupSet) | attrs == V.empty && null (asList tupSet) = "false"

63+ pretty (Relation attrs tupSet) | attrs == mempty && null (asList tupSet) = "false"

64− pretty (Relation attrs tupSet) | attrs == V.empty && asList tupSet == [RelationTuple V.empty V.empty] = "true"

64+ pretty (Relation attrs tupSet) | attrs == mempty && asList tupSet == [RelationTuple mempty mempty] = "true"

65− pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)

65+ pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet)

67instance Pretty Attribute where

68 pretty (Attribute n aTy) = pretty n <+> pretty (show aTy) -- workaround

@@ -76,7 +76,7 @@ instance Pretty RelationalExpr where

76 pretty (Extend ext r) = collectExtends r <> pretty ext <> "}"

77 pretty (MakeRelationFromExprs Nothing (TupleExprs () tupExprs)) = "relation" <> prettyBracesList tupExprs

78 pretty (MakeRelationFromExprs (Just attrExprs) (TupleExprs () tupExprs)) = "relation" <> prettyBracesList attrExprs <> prettyBracesList tupExprs

79− pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)

79+ pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet)

80 pretty (Union a b) = parens $ pretty' a <+> "union" <+> pretty' b

81 pretty (Join a b) = parens $ pretty' a <+> "join" <+> pretty' b

82 pretty (Rename n1 n2 relExpr) = parens $ pretty relExpr <+> "rename" <+> braces (pretty n1 <+> "as" <+> pretty n2)

@@ -130,7 +130,7 @@ instance Pretty AtomType where

130 pretty DateTimeAtomType = "DateTime"

131 pretty ByteStringAtomType = "ByteString"

132 pretty BoolAtomType = "Bool"

133− pretty (RelationAtomType attrs) = "relation " <+> prettyBracesList (V.toList attrs)

133+ pretty (RelationAtomType attrs) = "relation " <+> prettyBracesList (A.toList attrs)

134 pretty (ConstructedAtomType tcName tvMap) = pretty tcName <+> hsep (map pretty (M.toList tvMap)) --order matters

135 pretty RelationalExprAtomType = "RelationalExpr"

136 pretty (TypeVariableType x) = pretty x

src/lib/ProjectM36/Arbitrary.hs+1−1

@@ -84,7 +84,7 @@ maybeToRight y Nothing = Left y

84arbitraryRelationTuple :: Attributes -> WithTCMap Gen (Either RelationalError RelationTuple)

85arbitraryRelationTuple attris = do

86 tcMap <- ask

87− listOfMaybeAType <- lift $ mapM ((\aTy -> runReaderT (arbitrary' aTy) tcMap) . atomType) (V.toList attris)

87+ listOfMaybeAType <- lift $ mapM ((\aTy -> runReaderT (arbitrary' aTy) tcMap) . atomType) (V.toList (attributesVec attris))

88 case sequence listOfMaybeAType of

89 Left err -> pure $ Left err

90 Right listOfAttr -> do

src/lib/ProjectM36/AtomType.hs+7−7

@@ -211,7 +211,7 @@ isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConst

211

212isValidAtomTypeForTypeConstructor (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) tConsMap = do

213 evaldAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap M.empty) attrExprs

214− mapM_ (uncurry resolveAtomType) (zip (map A.atomType (V.toList attrs)) evaldAtomTypes)

214+ mapM_ (uncurry resolveAtomType) (zip (A.atomTypesList attrs) evaldAtomTypes)

215isValidAtomTypeForTypeConstructor aType tCons _ = Left (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))

216

217findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])

@@ -295,7 +295,7 @@ resolveTypeInAtom _ atom _ = Right atom

295-- Example: "Nothing" does not specify the the argument in "Maybe a", so allow delayed resolution in the tuple before it is added to the relation. Note that this resolution could cause a type error. Hardly a Hindley-Milner system.

296resolveTypesInTuple :: Attributes -> TypeConstructorMapping -> RelationTuple -> Either RelationalError RelationTuple

297resolveTypesInTuple resolvedAttrs tConss (RelationTuple _ tupAtoms) = do

298− newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom tConss) (zip (V.toList tupAtoms) $ map A.atomType (V.toList resolvedAttrs))

298+ newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom tConss) (zip (V.toList tupAtoms) $ A.atomTypesList resolvedAttrs)

299 Right (RelationTuple resolvedAttrs (V.fromList newAtoms))

300

301-- | Validate that the type is provided with complete type variables for type constructors.

@@ -314,7 +314,7 @@ validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =

314 _ -> Right ()

315validateAtomType (RelationAtomType attrs) tConss =

316 mapM_ (\attr ->

317− validateAtomType (A.atomType attr) tConss) (V.toList attrs)

317+ validateAtomType (A.atomType attr) tConss) (attributesVec attrs)

318validateAtomType (TypeVariableType x) _ = Left (TypeConstructorTypeVarMissing x)

319validateAtomType _ _ = pure ()

320

@@ -325,7 +325,7 @@ validateAttributes tConss attrs =

325 else

326 pure ()

327 where

328− errs = lefts $ map ((`validateAtomType` tConss) . A.atomType) (V.toList attrs)

328+ errs = lefts $ map (`validateAtomType` tConss) (A.atomTypesList attrs)

329

330--ensure that all type vars are fully resolved

331validateTypeVarMap :: TypeVarMap -> TypeConstructorMapping -> Either RelationalError ()

@@ -358,7 +358,7 @@ atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do

358 if notElem "_" [name1, name2] && name1 /= name2 then

359 Left $ AtomTypeMismatchError x y

360 else

361− atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2)

361+ atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip (attributesVec attrs1) (attributesVec attrs2))

362 return x

363atomTypeVerify x y = if x == y then

364 Right x

@@ -375,7 +375,7 @@ typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) zipped =

375 (M.toAscList b)

376

377prettyAtomType :: AtomType -> T.Text

378−prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"

378+prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList (attributesVec attrs))) `T.append` "}"

379prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))

380 where

381 showTypeVars (_, TypeVariableType x) = " " <> x

@@ -448,7 +448,7 @@ isResolvedType typ =

448 TypeVariableType _ -> False

449

450isResolvedAttributes :: Attributes -> Bool

451−isResolvedAttributes attrs = all isResolvedAttribute (V.toList attrs)

451+isResolvedAttributes attrs = all isResolvedAttribute (V.toList (attributesVec attrs))

452

453isResolvedAttribute :: Attribute -> Bool

454isResolvedAttribute = isResolvedType . A.atomType

src/lib/ProjectM36/Atomable.hs+1−1

@@ -237,7 +237,7 @@ typeToTypeConstructor x@ByteStringAtomType = PrimitiveTypeConstructor "ByteStrin

237typeToTypeConstructor x@BoolAtomType = PrimitiveTypeConstructor "Bool" x

238typeToTypeConstructor x@RelationalExprAtomType = PrimitiveTypeConstructor "RelationalExpr" x

239typeToTypeConstructor (RelationAtomType attrs)

240− = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList attrs

240+ = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList (attributesVec attrs)

241 where

242 attrToAttrExpr (Attribute n t) = AttributeAndTypeNameExpr n (typeToTypeConstructor t) ()

243typeToTypeConstructor (ConstructedAtomType tcName tvMap)

src/lib/ProjectM36/Attribute.hs+117−30

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

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

1module ProjectM36.Attribute where

2module ProjectM36.Attribute where

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.Error

@@ -10,16 +11,45 @@ import qualified Data.Map as M

10import Data.Either

11import Data.Either

12arity :: Attributes -> Int

13arity :: Attributes -> Int

13−arity = V.length

14+arity a = V.length (attributesVec a)

15+

16+instance Semigroup Attributes where

17+ attrsA <> attrsB =

18+ case joinAttributes attrsA attrsB of

19+ Left err -> error (show err)

20+ Right attrs' -> attrs'

21+

22+instance Monoid Attributes where

23+ mempty = Attributes mempty mempty

15emptyAttributes :: Attributes

25emptyAttributes :: Attributes

16−emptyAttributes = V.empty

26+emptyAttributes = mempty

18null :: Attributes -> Bool

28null :: Attributes -> Bool

19−null = V.null

29+null a = V.null (attributesVec a)

30+

31+singleton :: Attribute -> Attributes

32+singleton attr = Attributes (V.singleton attr) (HS.singleton attr)

33+

34+toList :: Attributes -> [Attribute]

35+toList attrs = V.toList (attributesVec attrs)

21attributesFromList :: [Attribute] -> Attributes

37attributesFromList :: [Attribute] -> Attributes

22−attributesFromList = V.fromList -- . L.nub --too expensive

38+attributesFromList attrsL = Attributes vec hset

39+ where

40+ vec = if length attrsL == HS.size hset then

41+ --fast path- no duplicates

42+ V.fromList attrsL

43+ else

44+ --duplicate detected, uniqueify while maintaining original ordering

45+ V.fromList uniquedL

46+ hset = HS.fromList attrsL

47+ uniquedL = fst $ foldr (\attr acc@(l,s) ->

48+ if HS.member attr s then

49+ acc

50+ else

51+ (l ++ [attr], HS.insert attr s))

52+ ([],mempty) attrsL

24attributeName :: Attribute -> AttributeName

54attributeName :: Attribute -> AttributeName

25attributeName (Attribute name _) = name

55attributeName (Attribute name _) = name

@@ -28,17 +58,16 @@ atomType :: Attribute -> AtomType

28atomType (Attribute _ atype) = atype

58atomType (Attribute _ atype) = atype

30atomTypes :: Attributes -> V.Vector AtomType

60atomTypes :: Attributes -> V.Vector AtomType

31−atomTypes = V.map atomType

61+atomTypes attrs = V.map atomType (attributesVec attrs)

33atomTypesList :: Attributes -> [AtomType]

63atomTypesList :: Attributes -> [AtomType]

34atomTypesList = V.toList . atomTypes

64atomTypesList = V.toList . atomTypes

36−--hm- no error-checking here

37addAttribute :: Attribute -> Attributes -> Attributes

66addAttribute :: Attribute -> Attributes -> Attributes

38−addAttribute attr attrs = attrs `V.snoc` attr

67+addAttribute attr attrs = attrs <> singleton attr

40--if some attribute names overlap but the types do not, then spit back an error

69--if some attribute names overlap but the types do not, then spit back an error

41−joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

70+{-joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

42joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length overlappingAttributes = Left (TupleAttributeTypeMismatchError overlappingAttributes)

71joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length overlappingAttributes = Left (TupleAttributeTypeMismatchError overlappingAttributes)

43 | V.length overlappingAttrsDifferentTypes > 0 = Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)

72 | V.length overlappingAttrsDifferentTypes > 0 = Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)

44 | otherwise = Right $ vectorUniqueify (attrs1 V.++ attrs2)

73 | otherwise = Right $ vectorUniqueify (attrs1 V.++ attrs2)

@@ -47,20 +76,47 @@ joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length

47 attrNames2 = V.map attributeName attrs2

76 attrNames2 = V.map attributeName attrs2

48 uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes

77 uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes

49 overlappingAttributes = V.filter (`V.elem` attrs2) attrs1

78 overlappingAttributes = V.filter (`V.elem` attrs2) attrs1

79+-}

80+joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

81+joinAttributes attrs1 attrs2 =

82+ if S.size overlappingNames == 0 then -- fast path, no overlapping names

83+ pure (concated id)

84+ else if attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 then -- check that atomtypes match

85+ pure (concated vectorUniqueify)

86+ else

87+ --special handling to validate that overlapping names have the same atom types

88+ Left (TupleAttributeTypeMismatchError (attributesForNames overlappingNames attrs1))

89+ where

90+ nameSet1 = attributeNameSet attrs1

91+ nameSet2 = attributeNameSet attrs2

92+ overlappingNames = S.intersection nameSet1 nameSet2

93+ concated f = Attributes (f (attributesVec attrs1 <> attributesVec attrs2)) (attributesSet attrs1 <> attributesSet attrs2)

51addAttributes :: Attributes -> Attributes -> Attributes

95addAttributes :: Attributes -> Attributes -> Attributes

52−addAttributes = (V.++)

96+addAttributes = (<>)

97+

98+member :: Attribute -> Attributes -> Bool

99+member attr attrs = HS.member attr (attributesSet attrs)

100

54deleteAttributeName :: AttributeName -> Attributes -> Attributes

101deleteAttributeName :: AttributeName -> Attributes -> Attributes

55−deleteAttributeName attrName = V.filter (\attr -> attributeName attr /= attrName)

102+deleteAttributeName attrName attrs = deleteAttributeNames (S.singleton attrName) attrs

103+

104+deleteAttributeNames :: S.Set AttributeName -> Attributes -> Attributes

105+deleteAttributeNames attrNames attrs = Attributes vec hset

106+ where

107+ vec = V.filter attrFilter (attributesVec attrs)

108+ hset = HS.filter attrFilter (attributesSet attrs)

109+ attrFilter attr = S.notMember (attributeName attr) attrNames

110

57renameAttribute :: AttributeName -> Attribute -> Attribute

111renameAttribute :: AttributeName -> Attribute -> Attribute

58renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo

112renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo

113

60renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes

114renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes

61−renameAttributes oldAttrName newAttrName = V.map renamer

115+renameAttributes oldAttrName newAttrName attrs = Attributes vec hset

62 where

116 where

117+ vec = V.map renamer (attributesVec attrs)

118+ hset = HS.map renamer (attributesSet attrs)

63− renamer attr = if attributeName attr == oldAttrName then

119+ renamer attr = if attributeName attr == oldAttrName then

64 renameAttribute newAttrName attr

120 renameAttribute newAttrName attr

65 else

121 else

66 attr

122 attr

@@ -71,7 +127,7 @@ atomTypeForAttributeName attrName attrs = do

71 return atype

127 return atype

128

73attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute

129attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute

74−attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of

130+attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) (attributesVec attrs) of

75 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

131 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

76 Just attr -> Right attr

132 Just attr -> Right attr

133

@@ -89,15 +145,18 @@ projectionAttributesForNames names attrsIn =

89 missingNames = attributeNamesNotContained names (S.fromList (V.toList (attributeNames attrsIn)))

145 missingNames = attributeNamesNotContained names (S.fromList (V.toList (attributeNames attrsIn)))

146

91attributesForNames :: S.Set AttributeName -> Attributes -> Attributes

147attributesForNames :: S.Set AttributeName -> Attributes -> Attributes

92−attributesForNames attrNameSet = V.filter filt

148+attributesForNames attrNameSet attrs = Attributes vec hset

149+

93 where

150 where

151+ vec = V.filter filt (attributesVec attrs)

152+ hset = HS.filter filt (attributesSet attrs)

94 filt attr = S.member (attributeName attr) attrNameSet

153 filt attr = S.member (attributeName attr) attrNameSet

154

96attributeNameSet :: Attributes -> S.Set AttributeName

155attributeNameSet :: Attributes -> S.Set AttributeName

97−attributeNameSet attrVec = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) attrVec

156+attributeNameSet attrs = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) (attributesVec attrs)

157

99attributeNames :: Attributes -> V.Vector AttributeName

158attributeNames :: Attributes -> V.Vector AttributeName

100−attributeNames = V.map attributeName

159+attributeNames attrs = V.map attributeName (attributesVec attrs)

101

160

102--checks if set s1 is wholly contained in the set s2

161--checks if set s1 is wholly contained in the set s2

103attributesContained :: Attributes -> Attributes -> Bool

162attributesContained :: Attributes -> Attributes -> Bool

@@ -118,42 +177,70 @@ attributeNamesNotContained subset superset = S.filter (`S.notMember` superset) s

118

177

119-- useful for display

178-- useful for display

120orderedAttributes :: Attributes -> [Attribute]

179orderedAttributes :: Attributes -> [Attribute]

121−orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList attrs)

180+orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList (attributesVec attrs))

122

181

123orderedAttributeNames :: Attributes -> [AttributeName]

182orderedAttributeNames :: Attributes -> [AttributeName]

124orderedAttributeNames attrs = map attributeName (orderedAttributes attrs)

183orderedAttributeNames attrs = map attributeName (orderedAttributes attrs)

125

184

126-- take two attribute sets and return an attribute set with the attributes which do not match

185-- take two attribute sets and return an attribute set with the attributes which do not match

186+--this is the function which benefits the most from the HashSet representation- this turned up in the insert performance test

127attributesDifference :: Attributes -> Attributes -> Attributes

187attributesDifference :: Attributes -> Attributes -> Attributes

128−attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)

188+{-attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)

129 where

189 where

130 diff a b = (a L.\\ b) ++ (b L.\\ a)

190 diff a b = (a L.\\ b) ++ (b L.\\ a)

191+-}

192+attributesDifference attrsA attrsB =

193+ if attributesSet attrsA == attributesSet attrsB then

194+ mempty

195+ else

196+ Attributes vec hset

197+ where

198+ hset = HS.difference setA setB <> HS.difference setB setA

199+ setA = attributesSet attrsA

200+ setB = attributesSet attrsB

201+ vec = V.filter (\attr -> HS.member attr hset) (attributesVec attrsA <> attributesVec attrsB)

131

202

132vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a

203vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a

133vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn

204vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn

134

205

135--check that each attribute only appears once

206--check that each attribute only appears once

136verifyAttributes :: Attributes -> Either RelationalError Attributes

207verifyAttributes :: Attributes -> Either RelationalError Attributes

137−verifyAttributes attrs = if collapsedAttrs /= attrs then

208+verifyAttributes attrs =

209+ if vecSet == attributesSet attrs then

210+ pure attrs

211+ else

138− Left (TupleAttributeTypeMismatchError (attributesDifference collapsedAttrs attrs))

212+ Left (TupleAttributeTypeMismatchError diffAttrs)

139− else

140− Right attrs

141 where

213 where

142− collapsedAttrs = vectorUniqueify attrs

214+ vecSet = V.foldr' HS.insert HS.empty (attributesVec attrs)

143−

215+ diffSet = HS.difference vecSet (attributesSet attrs) <> HS.difference (attributesSet attrs) vecSet

216+ diffAttrs = Attributes (V.fromList (HS.toList diffSet)) diffSet

217+

218+--used in Generics derivation for ADTs without named attributes- not to be used elsewhere

219+--drop first n attributes from vector representation

220+drop :: Int -> Attributes -> Attributes

221+drop c attrs = Attributes vec hset

222+ where

223+ droppedAttrs = V.take c (attributesVec attrs)

224+ vec = V.drop c (attributesVec attrs)

225+ hset = HS.filter (`V.notElem` droppedAttrs) hset

226+

227+-- use this in preference to (==) when the attribute ordering matters such as during tuple unions

144attributesEqual :: Attributes -> Attributes -> Bool

228attributesEqual :: Attributes -> Attributes -> Bool

145−attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2)

229+attributesEqual a b = attributesVec a == attributesVec b

146

230

147attributesAsMap :: Attributes -> M.Map AttributeName Attribute

231attributesAsMap :: Attributes -> M.Map AttributeName Attribute

148−attributesAsMap attrs = (M.fromList . V.toList) (V.map (\attr -> (attributeName attr, attr)) attrs)

232+attributesAsMap attrs = V.foldr' (\attr acc -> M.insert (attributeName attr) attr acc) mempty (attributesVec attrs)

233+

149

234

150-- | Left-biased union of attributes.

235-- | Left-biased union of attributes.

151union :: Attributes -> Attributes -> Attributes

236union :: Attributes -> Attributes -> Attributes

152−union attrsA attrsB = V.fromList (M.elems unioned)

237+union attrsA attrsB = Attributes vec hset

153 where

238 where

154− unioned = M.union (attributesAsMap attrsA) (attributesAsMap attrsB)

239+ hset = HS.union (attributesSet attrsA) (attributesSet attrsB)

240+ vec = HS.foldr (flip V.snoc) mempty hset

155

241

156intersection :: Attributes -> Attributes -> Attributes

242intersection :: Attributes -> Attributes -> Attributes

157−intersection attrsA attrsB = V.fromList (M.elems intersected)

243+intersection attrsA attrsB = Attributes vec hset

158 where

244 where

159− intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)

245+ hset = HS.intersection (attributesSet attrsA) (attributesSet attrsB)

246+ vec = HS.foldr (flip V.snoc) mempty hset

src/lib/ProjectM36/Base.hs+24−16

@@ -99,16 +99,23 @@ instance Hashable Attribute where

99 hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName

100

101-- | 'Attributes' represent the head of a relation.

102+data Attributes = Attributes (V.Vector Attribute) (HS.HashSet Attribute)

103+ deriving (NFData, Read, Hashable, Generic, Show)

104+

105+{-instance Show Attributes where

106+ show attrs = "attributesFromList [" <> L.intercalate " " (map (\attr -> "(" <> show attr <> ")") (V.toList (attributesVec attrs))) <> "]"

107+-}

102−type Attributes = V.Vector Attribute

108+attributesVec :: Attributes -> V.Vector Attribute

109+attributesVec (Attributes attrsVec _) = attrsVec

110+

111+attributesSet :: Attributes -> HS.HashSet Attribute

112+attributesSet (Attributes _ hs) = hs

113+

114+instance Eq Attributes where

115+ (Attributes _ a) == (Attributes _ b) = a == b

103

116

104−-- | Equality function for a set of attributes.

105−attributesEqual :: Attributes -> Attributes -> Bool

106−attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2

107− where

108− attrsAsSet = HS.fromList . V.toList

109−

110sortedAttributesIndices :: Attributes -> [(Int, Attribute)]

117sortedAttributesIndices :: Attributes -> [(Int, Attribute)]

111−sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs)

118+sortedAttributesIndices (Attributes attrs _) = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs)

112

119

113-- | The relation's tuple set is the body of the relation.

120-- | The relation's tuple set is the body of the relation.

114newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Read)

121newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Read)

@@ -127,8 +134,8 @@ instance NFData RelationTupleSet where rnf = genericRnf

127instance Hashable RelationTuple where

134instance Hashable RelationTuple where

128 --sanity check the tuple for attribute and tuple counts

135 --sanity check the tuple for attribute and tuple counts

129 --this bit me when tuples were being hashed before being verified

136 --this bit me when tuples were being hashed before being verified

130− hashWithSalt salt (RelationTuple attrs tupVec) = if V.length attrs /= V.length tupVec then

137+ hashWithSalt salt (RelationTuple attrs tupVec) = if V.length (attributesVec attrs) /= V.length tupVec then

131− error "invalid tuple: attributes and tuple count mismatch"

138+ error ("invalid tuple: attributes and tuple count mismatch " <> show (attributesVec attrs, tupVec))

132 else

139 else

133 salt `hashWithSalt`

140 salt `hashWithSalt`

134 sortedAttrs `hashWithSalt`

141 sortedAttrs `hashWithSalt`

@@ -142,19 +149,20 @@ instance Hashable RelationTuple where

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

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

143

150

144instance Eq RelationTuple where

151instance Eq RelationTuple where

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

152+ tuple1@(RelationTuple attrs1 _) == tuple2@(RelationTuple attrs2 _) =

153+ attrs1 == attrs2 && atomsEqual

146 where

154 where

147− atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) attrs of

155+ atomForAttribute attr (RelationTuple (Attributes attrs _) tupVec) = case V.findIndex (== attr) attrs of

148 Nothing -> Nothing

156 Nothing -> Nothing

149 Just index -> tupVec V.!? index

157 Just index -> tupVec V.!? index

150− atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) attrs1

158+ atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) (attributesVec attrs1)

151

159

152instance NFData RelationTuple where rnf = genericRnf

160instance NFData RelationTuple where rnf = genericRnf

153

161

154data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)

162data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)

155

163

156instance Eq Relation where

164instance Eq Relation where

157− Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2

165+ Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attrs1 == attrs2 && tupSet1 == tupSet2

158

166

159instance NFData Relation where rnf = genericRnf

167instance NFData Relation where rnf = genericRnf

160

168

@@ -598,7 +606,7 @@ attrTypeVars (Attribute _ aType) = case aType of

598 ByteStringAtomType -> S.empty

606 ByteStringAtomType -> S.empty

599 BoolAtomType -> S.empty

607 BoolAtomType -> S.empty

600 RelationalExprAtomType -> S.empty

608 RelationalExprAtomType -> S.empty

601− (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList attrs))

609+ (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList (attributesVec attrs)))

602 (ConstructedAtomType _ tvMap) -> M.keysSet tvMap

610 (ConstructedAtomType _ tvMap) -> M.keysSet tvMap

603 (TypeVariableType nam) -> S.singleton nam

611 (TypeVariableType nam) -> S.singleton nam

604

612

@@ -622,7 +630,7 @@ atomTypeVars DateTimeAtomType = S.empty

622atomTypeVars ByteStringAtomType = S.empty

630atomTypeVars ByteStringAtomType = S.empty

623atomTypeVars BoolAtomType = S.empty

631atomTypeVars BoolAtomType = S.empty

624atomTypeVars RelationalExprAtomType = S.empty

632atomTypeVars RelationalExprAtomType = S.empty

625−atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs))

633+atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList (attributesVec attrs)))

626atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

634atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

627atomTypeVars (TypeVariableType nam) = S.singleton nam

635atomTypeVars (TypeVariableType nam) = S.singleton nam

628

636

src/lib/ProjectM36/DataFrame.hs+6−6

@@ -2,7 +2,7 @@

2{- A dataframe is a strongly-typed, ordered list of named tuples. A dataframe differs from a relation in that its tuples are ordered.-}

3module ProjectM36.DataFrame where

4import ProjectM36.Base

5−import ProjectM36.Attribute as A

5+import ProjectM36.Attribute as A hiding (drop)

6import ProjectM36.Error

7import qualified ProjectM36.Relation as R

8import ProjectM36.Relation.Show.Term

@@ -81,7 +81,7 @@ compareTupleByOneAttributeName attr tuple1 tuple2 =

81 Right atom2 -> compareAtoms atom1 atom2

83atomForAttributeName :: AttributeName -> DataFrameTuple -> Either RelationalError Atom

84−atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of

84+atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) (attributesVec tupAttrs) of

85 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

86 Just index -> case tupVec V.!? index of

87 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

@@ -134,12 +134,12 @@ data DataFrameExpr = DataFrameExpr {

134dataFrameAsHTML :: DataFrame -> T.Text

135-- web browsers don't display tables with empty cells or empty headers, so we have to insert some placeholders- it's not technically the same, but looks as expected in the browser

136dataFrameAsHTML df

137− | length (tuples df) == 1 && L.null (attributes df) = style <>

137+ | length (tuples df) == 1 && A.null (attributes df) = style <>

138 tablestart <>

139 "<tr><th></th></tr>" <>

140 "<tr><td></td></tr>" <>

141 tablefooter <> "</table>"

142− | L.null (tuples df) && L.null (attributes df) = style <>

142+ | L.null (tuples df) && A.null (attributes df) = style <>

143 tablestart <>

144 "<tr><th></th></tr>" <>

145 tablefooter <>

@@ -162,7 +162,7 @@ tuplesAsHTML = foldr folder ""

162 folder tuple acc = acc <> tupleAsHTML tuple

163

164tupleAssocs :: DataFrameTuple -> [(AttributeName, Atom)]

165−tupleAssocs (DataFrameTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec)

165+tupleAssocs (DataFrameTuple attrs tupVec) = V.toList $ V.map (first attributeName) (V.zip (attributesVec attrs) tupVec)

166

167

168tupleAsHTML :: DataFrameTuple -> T.Text

@@ -174,7 +174,7 @@ tupleAsHTML tuple = "<tr>" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <>

174 atomAsHTML atom = atomToText atom

175

176attributesAsHTML :: Attributes -> [AttributeOrder] -> T.Text

177−attributesAsHTML attrs orders' = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"

177+attributesAsHTML attrs orders' = "<tr>" <> T.concat (map oneAttrHTML (A.toList attrs)) <> "</tr>"

178 where

179 oneAttrHTML attr = "<th>" <> prettyAttribute attr <> ordering (attributeName attr) <> "</th>"

180 ordering attrName = " " <> case L.find (\(AttributeOrder nam _) -> nam == attrName) orders' of

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

@@ -44,7 +44,7 @@ emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet

44mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation

45mkRelation attrs tupleSet =

46 --check that all attributes are unique- this cannot be done when creating attributes because the check can become expensive

47− let duplicateAttrNames = dupes (sort (map A.attributeName (V.toList attrs))) in

47+ let duplicateAttrNames = dupes (sort (map A.attributeName (V.toList (attributesVec attrs)))) in

48 if not (null duplicateAttrNames) then

49 Left (DuplicateAttributeNamesError (S.fromList duplicateAttrNames))

50 else

@@ -154,7 +154,7 @@ group groupAttrNames newAttrName rel = do

154 groupProjectionAttributes <- A.projectionAttributesForNames groupAttrNames (attributes rel)

155 let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes)

156 matchingRelTuple tupIn = case imageRelationFor tupIn rel of

157− Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2))

157+ Right rel2 -> RelationTuple (A.singleton groupAttr) (V.singleton (RelationAtom rel2))

158 Left _ -> undefined

159 mogrifier tupIn = pure (tupleExtend tupIn (matchingRelTuple tupIn))

160 newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes

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

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

38 let strHeader = V.map decodeUtf8 headerRaw

39 strMapRecords = V.map convertMap vecMapsRaw

40 convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)

41− attrNames = V.map A.attributeName attrs

41+ attrNameSet = A.attributeNameSet attrs

42− attrNameSet = S.fromList (V.toList attrNames)

43 headerSet = S.fromList (V.toList strHeader)

42 headerSet = S.fromList (V.toList strHeader)

44 parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType <* APT.endOfInput) textIn of

43 parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType <* APT.endOfInput) textIn of

45 Left err -> Left (ParseError (T.pack err))

44 Left err -> Left (ParseError (T.pack err))

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

47 makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]

46 makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]

48 makeTupleList tupMap = V.toList $ V.map (\attr ->

47 makeTupleList tupMap = V.toList $ V.map (\attr ->

49 either (Left . AttributeMappingError) Right $

48 either (Left . AttributeMappingError) Right $

50− parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) attrs

49+ parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) (attributesVec attrs)

51 if attrNameSet == headerSet then do

50 if attrNameSet == headerSet then do

52 tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)

51 tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)

53 case mkRelationFromList attrs tupleList of

52 case mkRelationFromList attrs tupleList of

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

@@ -1,7 +1,7 @@

1{-# OPTIONS_GHC -fno-warn-orphans #-}

2module ProjectM36.Relation.Show.CSV where

3import ProjectM36.Base

4−import ProjectM36.Attribute

4+import ProjectM36.Attribute as A

5import Data.Csv

6import ProjectM36.Tuple

7import qualified Data.ByteString.Lazy as BS

@@ -17,13 +17,13 @@ relationAsCSV (Relation attrs tupleSet)

17 | relValAttrs /= [] =

18 Left $ RelationValuedAttributesNotSupportedError (map attributeName relValAttrs)

19 --check that there is at least one attribute

20− | V.null attrs =

20+ | A.null attrs =

21 Left $ TupleAttributeCountMismatchError 0

22 | otherwise =

23 Right $ encodeByName bsAttrNames $ map RecordRelationTuple (asList tupleSet)

24 where

25− relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) attrs

25+ relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) (attributesVec attrs)

26− bsAttrNames = V.map (TE.encodeUtf8 . attributeName) attrs

26+ bsAttrNames = V.map (TE.encodeUtf8 . attributeName) (attributesVec attrs)

28{-

29instance ToRecord RelationTuple where

@@ -36,7 +36,7 @@ instance ToNamedRecord RecordRelationTuple where

36 toNamedRecord rTuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= RecordAtom v) (tupleAssocs $ unTuple rTuple)

38instance DefaultOrdered RecordRelationTuple where

39− headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (tupleAttributes tuple)

39+ headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (attributesVec (tupleAttributes tuple))

41newtype RecordAtom = RecordAtom {unAtom :: Atom}

src/lib/ProjectM36/Relation/Show/HTML.hs+2−2

@@ -3,6 +3,7 @@ import ProjectM36.Base

3import ProjectM36.Relation

4import ProjectM36.Tuple

5import ProjectM36.Atom

6+import ProjectM36.Attribute as A

6import ProjectM36.AtomType

7import ProjectM36.AtomType

7import qualified Data.List as L

8import qualified Data.List as L

8import Data.Text (Text, pack)

9import Data.Text (Text, pack)

@@ -11,10 +12,9 @@ import qualified Data.Text.IO as TIO

11#if __GLASGOW_HASKELL__ < 804

12#if __GLASGOW_HASKELL__ < 804

12import Data.Monoid

13import Data.Monoid

13#endif

14#endif

14−import qualified Data.Vector as V

16attributesAsHTML :: Attributes -> Text

17−attributesAsHTML attrs = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"

17+attributesAsHTML attrs = "<tr>" <> T.concat (map oneAttrHTML (A.toList attrs)) <> "</tr>"

18 where

19 oneAttrHTML attr = "<th>" <> prettyAttribute attr <> "</th>"

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

@@ -46,6 +46,8 @@ import Control.Exception

46import GHC.Paths

47#endif

49+import Debug.Trace

50+

49data DatabaseContextExprDetails = CountUpdatedTuples

51data DatabaseContextExprDetails = CountUpdatedTuples

51databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc

53databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc

@@ -788,7 +790,7 @@ updateTupleWithAtomExprs exprMap context graph tupIn = do

788-}

790-}

789--run verification on all constraints

791--run verification on all constraints

790checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

792checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

791−checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

793+checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do

792 mapM_ (uncurry checkIncDep) (M.toList deps)

794 mapM_ (uncurry checkIncDep) (M.toList deps)

793 where

795 where

794 potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)

796 potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)

@@ -804,6 +806,7 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

804 deps = inclusionDependencies context

806 deps = inclusionDependencies context

805 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment

807 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment

806 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

808 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

809+ traceShowM ("incdep", subsetExpr, supersetExpr)

807 let process = runProcessExprM UncommittedContextMarker

810 let process = runProcessExprM UncommittedContextMarker

808 gfSubsetExpr = process (processRelationalExpr subsetExpr)

811 gfSubsetExpr = process (processRelationalExpr subsetExpr)

809 gfSupersetExpr = process (processRelationalExpr supersetExpr)

812 gfSupersetExpr = process (processRelationalExpr supersetExpr)

@@ -814,11 +817,11 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

814 typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)

817 typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)

815 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))

818 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))

816 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

819 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

817− gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)

820+ gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr (traceShow ("checkCon", checkExpr) checkExpr))

818 gfEnv' = freshGraphRefRelationalExprEnv (Just context) potentialGraph

821 gfEnv' = freshGraphRefRelationalExprEnv (Just context) potentialGraph

819 case gfEvald of

822 case gfEvald of

820 Left err -> Left err

823 Left err -> Left err

821− Right resultRel -> if resultRel == relationTrue then

824+ Right resultRel -> if traceShow ("result", resultRel, relationTrue) (resultRel == relationTrue) then

822 pure ()

825 pure ()

823 else

826 else

824 Left (InclusionDependencyCheckError depName)

827 Left (InclusionDependencyCheckError depName)

@@ -1165,7 +1168,7 @@ evalGraphRefTupleExprs mAttrs (TupleExprs fixedMarker tupleExprL) = do

1165 lift $ except $ resolveAttributes accAttr tupAttr

1168 lift $ except $ resolveAttributes accAttr tupAttr

1166 mostResolvedTypes <-

1169 mostResolvedTypes <-

1167 foldM (\acc tup -> do

1170 foldM (\acc tup -> do

1168− let zipped = zip (V.toList $ tupleAttributes tup) acc

1171+ let zipped = zip (V.toList . attributesVec $ tupleAttributes tup) acc

1169 accNames = S.fromList $ map A.attributeName acc

1172 accNames = S.fromList $ map A.attributeName acc

1170 tupNames = A.attributeNameSet (tupleAttributes tup)

1173 tupNames = A.attributeNameSet (tupleAttributes tup)

1171 attrNamesDiff = S.union (S.difference accNames tupNames) (S.difference tupNames accNames)

1174 attrNamesDiff = S.union (S.difference accNames tupNames) (S.difference tupNames accNames)

@@ -1176,7 +1179,7 @@ evalGraphRefTupleExprs mAttrs (TupleExprs fixedMarker tupleExprL) = do

1176 pure nextTupleAttrs

1179 pure nextTupleAttrs

1177 else

1180 else

1178 throwError (TupleAttributeTypeMismatchError diff)

1181 throwError (TupleAttributeTypeMismatchError diff)

1179− ) (V.toList $ tupleAttributes headTuple) tailTuples

1182+ ) (V.toList . attributesVec $ tupleAttributes headTuple) tailTuples

1180 pure (A.attributesFromList mostResolvedTypes)

1183 pure (A.attributesFromList mostResolvedTypes)

1181 --strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same

1184 --strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same

1182 tConsMap <- case singularTransactions tupleExprL of

1185 tConsMap <- case singularTransactions tupleExprL of

@@ -1500,7 +1503,7 @@ relationVariablesAsRelation ctx graph = do

1500 let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph

1503 let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph

1501 gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

1504 gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

1502 pure (rvName, gfType)

1505 pure (rvName, gfType)

1503− relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]

1506+ relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributesVec (attributes rel))]

1504 attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]

1507 attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]

1505 attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of

1508 attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of

1506 Left err -> error ("relationVariablesAsRelation pooped " ++ show err)

1509 Left err -> error ("relationVariablesAsRelation pooped " ++ show err)

src/lib/ProjectM36/Serialise/Base.hs+11−1

@@ -13,6 +13,7 @@ import Data.Word

13import qualified Data.List.NonEmpty as NE

14import qualified Data.Vector as V

15import Data.Time.Calendar (Day,toGregorian,fromGregorian)

16+import qualified Data.HashSet as HS

17deriving via WineryVariant Atom instance Serialise Atom

18deriving via WineryVariant Atom instance Serialise Atom

18deriving via WineryVariant AtomType instance Serialise AtomType

19deriving via WineryVariant AtomType instance Serialise AtomType

@@ -72,5 +73,14 @@ instance Serialise Day where

72 extractor = fromGregorianTup <$> extractor

73 extractor = fromGregorianTup <$> extractor

73 decodeCurrent = fromGregorianTup <$> decodeCurrent

74 decodeCurrent = fromGregorianTup <$> decodeCurrent

76+instance Serialise Attributes where

77+ schemaGen _ = SVector <$> getSchema (Proxy @Attribute)

78+ toBuilder attrs = varInt (V.length (attributesVec attrs)) <> foldMap toBuilder (V.toList (attributesVec attrs))

79+ extractor =

80+ let mkAttrs x = Attributes x (HS.fromList (V.toList x)) in

81+ mkAttrs <$> extractListBy extractor

76−

83+ decodeCurrent = do

84+ n <- decodeVarInt

85+ l <- replicateM n decodeCurrent

86+ pure (Attributes (V.fromList l) (HS.fromList l))

src/lib/ProjectM36/Tuple.hs+31−28

@@ -1,7 +1,7 @@

1module ProjectM36.Tuple where

2import ProjectM36.Base

3import ProjectM36.Error

4−import ProjectM36.Attribute

4+import ProjectM36.Attribute as A

5import ProjectM36.Atom

6import ProjectM36.AtomType

7import ProjectM36.DataTypes.Primitive

@@ -14,20 +14,22 @@ import Control.Monad

14import Control.Arrow

15import Data.Maybe

17+import Debug.Trace

18+

17emptyTuple :: RelationTuple

19emptyTuple :: RelationTuple

18−emptyTuple = RelationTuple V.empty V.empty

20+emptyTuple = RelationTuple mempty mempty

20tupleSize :: RelationTuple -> Int

22tupleSize :: RelationTuple -> Int

21−tupleSize (RelationTuple tupAttrs _) = V.length tupAttrs

23+tupleSize (RelationTuple tupAttrs _) = arity tupAttrs

23tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName

25tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName

24−tupleAttributeNameSet (RelationTuple tupAttrs _) = S.fromList $ V.toList $ V.map attributeName tupAttrs

26+tupleAttributeNameSet (RelationTuple tupAttrs _) = attributeNameSet tupAttrs

26tupleAttributes :: RelationTuple -> Attributes

28tupleAttributes :: RelationTuple -> Attributes

27tupleAttributes (RelationTuple tupAttrs _) = tupAttrs

29tupleAttributes (RelationTuple tupAttrs _) = tupAttrs

29tupleAssocs :: RelationTuple -> [(AttributeName, Atom)]

31tupleAssocs :: RelationTuple -> [(AttributeName, Atom)]

30−tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec)

32+tupleAssocs (RelationTuple attrs tupVec) = V.toList $ V.map (first attributeName) (V.zip (attributesVec attrs) tupVec)

32orderedTupleAssocs :: RelationTuple -> [(AttributeName, Atom)]

34orderedTupleAssocs :: RelationTuple -> [(AttributeName, Atom)]

33orderedTupleAssocs tup@(RelationTuple attrVec _) = map (\attr -> (attributeName attr, atomForAttr (attributeName attr))) oAttrs

35orderedTupleAssocs tup@(RelationTuple attrVec _) = map (\attr -> (attributeName attr, atomForAttr (attributeName attr))) oAttrs

@@ -42,7 +44,7 @@ tupleAtoms :: RelationTuple -> V.Vector Atom

42tupleAtoms (RelationTuple _ tupVec) = tupVec

44tupleAtoms (RelationTuple _ tupVec) = tupVec

44atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom

46atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom

45−atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of

47+atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) (attributesVec tupAttrs) of

46 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

48 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

47 Just index -> case tupVec V.!? index of

49 Just index -> case tupVec V.!? index of

48 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

50 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

@@ -59,7 +61,7 @@ vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNa

59 Right $ V.map mapper attrNameVec

61 Right $ V.map mapper attrNameVec

60 where

62 where

61 unknownAttrNames = V.filter (`V.notElem` attributeNames attrs) attrNameVec

63 unknownAttrNames = V.filter (`V.notElem` attributeNames attrs) attrNameVec

62− mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (V.map attributeName attrs))

64+ mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (attributeNames attrs))

65relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation

67relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation

@@ -86,10 +88,10 @@ mkRelationTuples attrs = map mapper

86 mapper = mkRelationTuple attrs

88 mapper = mkRelationTuple attrs

88mkRelationTupleFromMap :: M.Map AttributeName Atom -> RelationTuple

90mkRelationTupleFromMap :: M.Map AttributeName Atom -> RelationTuple

89−mkRelationTupleFromMap attrMap = RelationTuple attrs (V.map (attrMap M.!) attrNames)

91+mkRelationTupleFromMap attrMap = RelationTuple (attributesFromList attrs) (V.map (attrMap M.!) (V.fromList attrNames))

90 where

92 where

91− attrNames = V.fromList (M.keys attrMap)

93+ attrNames = M.keys attrMap

92− attrs = V.map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames

94+ attrs = map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames

94--return error if attribute names match but their types do not

96--return error if attribute names match but their types do not

95singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple]

97singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple]

@@ -120,8 +122,8 @@ singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple

120 return $ Just $ RelationTuple joinedAttrs newVec

122 return $ Just $ RelationTuple joinedAttrs newVec

121 where

123 where

122 keysIntersection = V.map attributeName attrsIntersection

124 keysIntersection = V.map attributeName attrsIntersection

123− attrsIntersection = V.filter (`V.elem` tupAttrs1) tupAttrs2

125+ attrsIntersection = V.filter (`V.elem` attributesVec tupAttrs1) (attributesVec tupAttrs2)

124− newVec = V.map (findAtomForAttributeName . attributeName) joinedAttrs

126+ newVec = V.map (findAtomForAttributeName . attributeName) (attributesVec joinedAttrs)

125 --search both tuples for the attribute

127 --search both tuples for the attribute

126 findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]

128 findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]

127

129

@@ -138,21 +140,21 @@ vectorUnion v1 v2 = V.foldr folder v1 v2

138tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple

140tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple

139tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2) = RelationTuple newAttrs newVec

141tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2) = RelationTuple newAttrs newVec

140 where

142 where

141− newAttrs = tupAttrs1 V.++ tupAttrs2

143+ newAttrs = tupAttrs1 <> tupAttrs2

142− newVec = tupVec1 V.++ tupVec2

144+ newVec = tupVec1 <> tupVec2

143

145

144tupleAtomExtend :: AttributeName -> Atom -> RelationTuple -> RelationTuple

146tupleAtomExtend :: AttributeName -> Atom -> RelationTuple -> RelationTuple

145tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup

147tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup

146 where

148 where

147− newTup = RelationTuple (V.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)

149+ newTup = RelationTuple (A.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)

148

150

149--this could be cheaper- it may not be wortwhile to update all the tuples for projection, but then the attribute management must be slightly different- perhaps the attributes should be a vector of association tuples [(name, index)]

151--this could be cheaper- it may not be wortwhile to update all the tuples for projection, but then the attribute management must be slightly different- perhaps the attributes should be a vector of association tuples [(name, index)]

150tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple

152tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple

151tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec

153tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec

152 where

154 where

153− deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) attrs

155+ deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) (attributesVec attrs)

154 indexDeleter = V.ifilter (\index _ -> V.notElem index deleteIndices)

156 indexDeleter = V.ifilter (\index _ -> V.notElem index deleteIndices)

155− newAttrs = indexDeleter attrs

157+ newAttrs = deleteAttributeNames projectAttrs attrs

156 newTupVec = indexDeleter tupVec

158 newTupVec = indexDeleter tupVec

157

159

158--return the attributes and atoms which are equal in both vectors

160--return the attributes and atoms which are equal in both vectors

@@ -162,12 +164,10 @@ tupleIntersection tuple1 tuple2 = RelationTuple newAttrs newTupVec

162 where

164 where

163 attrs1 = tupleAttributes tuple1

165 attrs1 = tupleAttributes tuple1

164 attrs2 = tupleAttributes tuple2

166 attrs2 = tupleAttributes tuple2

167+ intersectAttrs = A.intersection attrs1 attrs2

165− matchingIndices = V.findIndices (\attr -> V.elem attr attrs2 &&

168+ matchingIndices = V.findIndices (\attr -> A.member attr intersectAttrs) (attributesVec attrs1)

166− atomForAttributeName (attributeName attr) tuple1 ==

167− atomForAttributeName (attributeName attr) tuple2

168− ) attrs1

169 indexFilter = V.ifilter (\index _ -> V.elem index matchingIndices)

170− newAttrs = indexFilter attrs1

170+ newAttrs = deleteAttributeNames (A.attributeNameSet intersectAttrs) attrs1

171 newTupVec = indexFilter (tupleAtoms tuple1)

172

173-- | An optimized form of tuple update which updates vectors efficiently.

@@ -175,19 +175,19 @@ updateTupleWithAtoms :: M.Map AttributeName Atom -> RelationTuple -> RelationTup

175updateTupleWithAtoms updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec

176 where

177 updateKeysSet = M.keysSet updateMap

178− updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)

178+ updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed (attributesVec attrs))

179 newVec = V.update tupVec updateVec

180 updateVec = V.map (\(index, attr) -> (index, updateMap M.! attributeName attr)) updateKeysIVec

181

182tupleToMap :: RelationTuple -> M.Map AttributeName Atom

183tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList

184 where

185− assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs)

185+ assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed (attributesVec attrs))

186

187verifyTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

188−verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs

188+verifyTuple attrs tuple = let attrsTypes = A.atomTypes attrs

189 tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in

190− if V.length attrs /= V.length tupleTypes then

190+ if A.arity attrs /= V.length tupleTypes then

191 Left $ TupleAttributeCountMismatchError 0

192 else do

193 mapM_ (uncurry atomTypeVerify) (V.zip attrsTypes tupleTypes)

@@ -199,7 +199,7 @@ reorderTuple :: Attributes -> RelationTuple -> RelationTuple

199reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then

200 tupIn

201 else

202− RelationTuple attrs (V.map mapper attrs)

202+ RelationTuple attrs (V.map mapper (attributesVec attrs))

203 where

204 mapper attr = case atomForAttributeName (attributeName attr) tupIn of

205 Left err -> error ("logic bug in reorderTuple: " ++ show err)

@@ -207,4 +207,7 @@ reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then

207

208--used in Generics derivation for ADTs without named attributes

209trimTuple :: Int -> RelationTuple -> RelationTuple

210−trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals)

210+trimTuple index (RelationTuple attrs vals) =

211+ RelationTuple newAttrs (V.drop index vals)

212+ where

213+ newAttrs = A.drop index attrs

src/lib/ProjectM36/Tupleable.hs+10−8

@@ -38,13 +38,14 @@ import qualified Data.Text as T

38import qualified Data.Vector as V

39import GHC.Generics

40import ProjectM36.Atomable

41−import ProjectM36.Attribute hiding (null)

41+import ProjectM36.Attribute as A hiding (null, toList)

42import ProjectM36.Base

43import ProjectM36.DataTypes.Primitive

44import ProjectM36.Error

45import ProjectM36.Tuple

46import ProjectM36.TupleSet

47import qualified Data.Set as S

48+import qualified Data.HashSet as HS

49{-import Data.Binary

50{-import Data.Binary

50import Control.DeepSeq

51import Control.DeepSeq

@@ -89,7 +90,7 @@ toInsertExpr vals rvName = do

90-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'Data.Proxy'.

91-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'Data.Proxy'.

91toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr

92toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr

92−toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))

93+toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList (attributesVec attrs)))

93 where

94 where

94 attrs = toAttributes (Proxy :: Proxy a)

95 attrs = toAttributes (Proxy :: Proxy a)

@@ -228,11 +229,12 @@ instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) whe

228 toTupleG opts (M1 v) = RelationTuple attrs atoms

229 toTupleG opts (M1 v) = RelationTuple attrs atoms

229 where

230 where

230 attrsToCheck = toAttributesG opts v

231 attrsToCheck = toAttributesG opts v

231− counter = V.generate (V.length attrsToCheck) id

232+ counter = V.generate (arity attrsToCheck) id

233+ attrs = Attributes attrsV (HS.fromList (V.toList attrsV))

232− attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then

234+ attrsV = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then

233 Attribute ("attr" <> T.pack (show (num + 1))) typ

235 Attribute ("attr" <> T.pack (show (num + 1))) typ

234 else

236 else

235− attr) counter attrsToCheck

237+ attr) counter (attributesVec attrsToCheck)

236 atoms = V.fromList (toAtomsG v)

238 atoms = V.fromList (toAtomsG v)

237 toAttributesG opts (M1 v) = toAttributesG opts v

239 toAttributesG opts (M1 v) = toAttributesG opts v

238 fromTupleG opts tup = M1 <$> fromTupleG opts tup

240 fromTupleG opts tup = M1 <$> fromTupleG opts tup

@@ -241,7 +243,7 @@ instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) whe

241-- product types

243-- product types

242instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where

244instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where

243 toTupleG = error "toTupleG"

245 toTupleG = error "toTupleG"

244− toAttributesG opts ~(x :*: y) = toAttributesG opts x V.++ toAttributesG opts y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception

246+ toAttributesG opts ~(x :*: y) = toAttributesG opts x <> toAttributesG opts y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception

245 fromTupleG opts tup = (:*:) <$> fromTupleG opts tup <*> fromTupleG opts processedTuple

247 fromTupleG opts tup = (:*:) <$> fromTupleG opts tup <*> fromTupleG opts processedTuple

246 where

248 where

247 processedTuple = if isRecordTypeG (undefined :: a x) then

249 processedTuple = if isRecordTypeG (undefined :: a x) then

@@ -253,7 +255,7 @@ instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where

253--selector/record

255--selector/record

254instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

256instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

255 toTupleG = error "toTupleG"

257 toTupleG = error "toTupleG"

256− toAttributesG opts m@(M1 v) = V.singleton (Attribute modifiedName aType)

258+ toAttributesG opts m@(M1 v) = A.singleton (Attribute modifiedName aType)

257 where

259 where

258 name = T.pack (selName m)

260 name = T.pack (selName m)

259 modifiedName = if T.null name then

261 modifiedName = if T.null name then

@@ -268,7 +270,7 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

268 val <- atomv atom

270 val <- atomv atom

269 pure (M1 val)

271 pure (M1 val)

270 where

272 where

271− expectedAtomType = atomType (V.head (toAttributesG opts (undefined :: M1 S c a x)))

273+ expectedAtomType = atomType (V.head (attributesVec (toAttributesG opts (undefined :: M1 S c a x))))

272 atomv atom = maybe (Left (AtomTypeMismatchError

274 atomv atom = maybe (Left (AtomTypeMismatchError

273 expectedAtomType

275 expectedAtomType

274 (atomTypeForAtom atom)

276 (atomTypeForAtom atom)

test/Client/Simple.hs+1−2

@@ -9,7 +9,6 @@ import System.IO.Temp

9import System.FilePath

10import ProjectM36.TupleSet

11import ProjectM36.Attribute

12−import qualified Data.Vector as V

13import qualified Data.Map as M

12import qualified Data.Map as M

15main :: IO ()

14main :: IO ()

@@ -59,7 +58,7 @@ testSimpleCommitFailure = TestCase $ do

59 execute $ Assign "x" (ExistingRelation relationTrue)

58 execute $ Assign "x" (ExistingRelation relationTrue)

60 --cause error

59 --cause error

61 execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)

60 execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)

62− let expectedErr = Left (RelError (RelationTypeMismatchError V.empty failAttrs))

61+ let expectedErr = Left (RelError (RelationTypeMismatchError mempty failAttrs))

63 assertEqual "dbc error" expectedErr err

62 assertEqual "dbc error" expectedErr err

65-- #176 default merge couldn't handle Update

64-- #176 default merge couldn't handle Update

test/Relation/Basic.hs+1−1

@@ -65,7 +65,7 @@ validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = foldr (\tuple

65 attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of

66 Left _ -> False

67 Right atom -> Right (atomTypeForAtom atom) ==

68− A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)

68+ A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributesVec (attributes rel))

70simpleRel :: Relation

71simpleRel = case mkRelation attrs tupleSet of

test/Relation/Tupleable.hs+5−4

@@ -13,7 +13,7 @@

13import Test.HUnit

14import ProjectM36.Tupleable.Deriving

15import ProjectM36.Atomable

16−import ProjectM36.Attribute

16+import ProjectM36.Attribute as A

17import ProjectM36.Error

18import ProjectM36.Base

19import Control.DeepSeq (NFData)

@@ -110,7 +110,7 @@ main = do

110 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

111

112testList :: Test

113−testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple, testAddPrefixField, testDropPrefixField, testAddSuffixField, testDropSuffixField, testUpperCaseField, testLowerCaseField, testTitleCaseField, testCamelCaseField, testPascalCaseField, testSnakeCaseField, testSpinalCaseField, testTrainCaseField, testAsIsCodec, testAsIsField, testComposeRLCodec, testComposeRLField, testComposeLRCodec, testComposeLRField]

113+testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8 ,testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple, testAddPrefixField, testDropPrefixField, testAddSuffixField, testDropSuffixField, testUpperCaseField, testLowerCaseField, testTitleCaseField, testCamelCaseField, testPascalCaseField, testSnakeCaseField, testSpinalCaseField, testTrainCaseField, testAsIsCodec, testAsIsField, testComposeRLCodec, testComposeRLField, testComposeLRCodec, testComposeLRField]

114

115testADT1 :: Test

116testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example))

@@ -148,7 +148,7 @@ testADT7 :: Test

148testADT7 = TestCase $ do

149 let example = Test7C (Test7AC 3)

150 assertEqual "atom type" (Right example) (fromTuple (toTuple example))

151− let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))

151+ let expectedAttrs = A.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))

152 assertEqual "adt atomtype" expectedAttrs (toAttributes (Proxy :: Proxy Test7T))

153

154testADT8 :: Test

@@ -222,7 +222,8 @@ testDeleteExpr = TestCase $ do

222testReorderedTuple :: Test

223testReorderedTuple = TestCase $ do

224 let tupleRev :: RelationTuple -> RelationTuple

225− tupleRev (RelationTuple v1 v2) = RelationTuple (V.reverse v1) (V.reverse v2)

225+ tupleRev (RelationTuple v1 v2) = RelationTuple (revAttrs v1) (V.reverse v2)

226+ revAttrs attrs = A.attributesFromList (reverse (A.toList attrs))

226 expected = Test2C {attrB = 3,

227 expected = Test2C {attrB = 3,

227 attrC = 4}

228 attrC = 4}

228 actual = fromTuple . tupleRev . toTuple $ expected

229 actual = fromTuple . tupleRev . toTuple $ expected