84b3b93 · project-m36 · git.iko.soy

ProjectM36/Attribute.hs+5−2

compare with master

unifiedsplit

@@ -31,6 +31,9 @@ attributesFromList attrList = mergedAttributes

31attributeName :: Attribute -> AttributeName

32attributeName (Attribute name _) = name

33

34+atomType :: Attribute -> AtomType

35+atomType (Attribute _ atype) = atype

36+

34isRelationAtomType :: AtomType -> Bool

37isRelationAtomType :: AtomType -> Bool

35isRelationAtomType (RelationAtomType _) = True

38isRelationAtomType (RelationAtomType _) = True

36isRelationAtomType _ = False

39isRelationAtomType _ = False

@@ -67,11 +70,11 @@ renameAttributes oldAttrName newAttrName attrs = V.map renamer attrs

67

70

68atomTypeForAttributeName :: AttributeName -> Attributes -> Maybe AtomType

71atomTypeForAttributeName :: AttributeName -> Attributes -> Maybe AtomType

69atomTypeForAttributeName attrName attrs = case attr of

72atomTypeForAttributeName attrName attrs = case attr of

70− (Just (Attribute _ atomType)) -> Just atomType

73+ (Just (Attribute _ atype)) -> Just atype

71 _ -> Nothing

74 _ -> Nothing

72 where

75 where

73 attr = attributeForName attrName attrs

76 attr = attributeForName attrName attrs

74−

77+

75attributeForName :: AttributeName -> Attributes -> Maybe Attribute

78attributeForName :: AttributeName -> Attributes -> Maybe Attribute

76attributeForName attrName attrs = V.find ((attrName ==) . attributeName) attrs

79attributeForName attrName attrs = V.find ((attrName ==) . attributeName) attrs

77

80

ProjectM36/Error.hs+7−1

@@ -1,6 +1,11 @@

1+{-# LANGUAGE DeriveGeneric #-}

1module ProjectM36.Error where

2module ProjectM36.Error where

2import ProjectM36.Base

3import ProjectM36.Base

3import qualified Data.UUID as U

4import qualified Data.UUID as U

5+import Control.DeepSeq (NFData, rnf)

6+import Control.DeepSeq.Generics (genericRnf)

7+import GHC.Generics (Generic)

8+

4

9

5data RelationalError = NoSuchAttributeNameError AttributeName

10data RelationalError = NoSuchAttributeNameError AttributeName

6 | TupleAttributeCountMismatchError Int --attribute name

11 | TupleAttributeCountMismatchError Int --attribute name

@@ -19,6 +24,7 @@ data RelationalError = NoSuchAttributeNameError AttributeName

19 | NoSuchHeadNameError HeadName

24 | NoSuchHeadNameError HeadName

20 | TransactionIsNotAHeadError U.UUID

25 | TransactionIsNotAHeadError U.UUID

21 | TransactionGraphCycleError U.UUID

26 | TransactionGraphCycleError U.UUID

22− deriving (Show,Eq)

27+ deriving (Show,Eq,Generic)

23

28

24

29

30+instance NFData RelationalError where rnf = genericRnf

ProjectM36/Tuple.hs+8−15

@@ -146,21 +146,14 @@ tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList

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

147

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

149−verifyTuple attrs tuple = if V.length attrs /= V.length (tupleAtoms tuple) then

149+verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs

150+ tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in

151+ if V.length attrs /= V.length tupleTypes then

150− Left $ TupleAttributeCountMismatchError 0

152+ Left $ TupleAttributeCountMismatchError 0

151− else

153+ else if attrsTypes /= tupleTypes then

152−

153− V.foldr (\attr acc ->

154− case atomForAttributeName (attributeName attr) tuple of

155− Left err -> Left err

156− Right atom -> case atomTypeForAttributeName (attributeName attr) (tupleAttributes tuple) of

157− Nothing -> Left $ NoSuchAttributeNameError (attributeName attr)

158− Just expectedAtomType -> if atomTypeForAtom atom == expectedAtomType

159− then

160− acc

161− else

162− Left $ TupleAttributeTypeMismatchError (attributesFromList [attr])

154+ Left $ TupleAttributeTypeMismatchError (attributesDifference attrs (tupleAttributes tuple))

163− ) (Right tuple) attrs

155+ else

156+ Right $ tuple

164

157

165

158

166

159

ProjectM36/TupleSet.hs+10−4

@@ -3,8 +3,10 @@ import ProjectM36.Base

3import ProjectM36.Tuple

4import ProjectM36.Error

5import qualified Data.HashSet as HS

6−import Control.Monad

6+--import Control.Monad (forM)

7import qualified Data.Vector as V

8+import qualified Control.Parallel.Strategies as P

9+import Data.Either

8

10

9emptyTupleSet :: RelationTupleSet

11emptyTupleSet :: RelationTupleSet

10emptyTupleSet = HS.empty

12emptyTupleSet = HS.empty

@@ -16,9 +18,13 @@ singletonTupleSet = HS.singleton emptyTuple

16

18

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

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

18verifyTupleSet attrs tupleSet = do

20verifyTupleSet attrs tupleSet = do

19− --check that all tuples have the same types

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

20− tupleList <- forM (HS.toList tupleSet) (verifyTuple attrs)

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

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

24+ if length (lefts tupleList) > 0 then

25+ Left $ head (lefts tupleList)

26+ else

21− return $ HS.fromList tupleList

27+ return $ HS.fromList (rights tupleList)

22

28

23mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet

29mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet

24mkTupleSet attrs tuples = verifyTupleSet attrs tupSet

30mkTupleSet attrs tuples = verifyTupleSet attrs tupSet

benchmark/bigrel.hs+7−2

@@ -20,13 +20,18 @@ main = matrixRun

20 --intmapMatrixRun

21

22-- takes 30 minutes to run and 1.1 GB

23−matrixRun = do

23+matrixRestrictRun = do

24 case matrixRelation 100 100000 of

25 Left err -> putStrLn (show err)

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

27 Left err -> putStrLn (show err)

28 Right rel -> dumpcsv rel

29

30+matrixRun = do

31+ case matrixRelation 100 100000 of

32+ Left err -> putStrLn (show err)

33+ Right rel -> putStrLn "Done"

34+

30intmapMatrixRun = do

35intmapMatrixRun = do

31 let matrix = intmapMatrixRelation 100 100000

36 let matrix = intmapMatrixRelation 100 100000

32 putStrLn (show matrix)

37 putStrLn (show matrix)

@@ -53,4 +58,4 @@ vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tu

53 mapper tupCount = V.replicate attributeCount (IntAtom tupCount)

58 mapper tupCount = V.replicate attributeCount (IntAtom tupCount)

54

59

55instance Hash.Hashable (V.Vector Atom) where

60instance Hash.Hashable (V.Vector Atom) where

56− hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)

61+ hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)

project-m36.cabal+2−2

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

7Cabal-Version: >= 1.2

8

9Library

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

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

11 Exposed-Modules: ProjectM36.Error,

12 ProjectM36.Transaction,

13 ProjectM36.Transaction.Show,

@@ -40,7 +40,7 @@ Executable bigrel

40 ProjectM36.Error,

41 ProjectM36.Relation.Show.CSV

42 main-is: benchmark/bigrel.hs

43− GHC-Options: -Wall

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

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

45

46Test-Suite test-tutoriald