91cfdd0 · project-m36 · git.iko.soy

ProjectM36/Attribute.hs+1−10

compare with master

unifiedsplit

@@ -6,7 +6,6 @@ import qualified Data.List as L

6import qualified Data.Vector as V

7import qualified Data.Hashable as Hash

8import qualified Data.HashSet as HS

9−import Data.Maybe

10

9

11arity :: Attributes -> Int

10arity :: Attributes -> Int

12arity = V.length

11arity = V.length

@@ -17,16 +16,8 @@ emptyAttributes = V.empty

17null :: Attributes -> Bool

16null :: Attributes -> Bool

18null = V.null

17null = V.null

19

18

20−--merges duplicates

21attributesFromList :: [Attribute] -> Attributes

19attributesFromList :: [Attribute] -> Attributes

22−attributesFromList attrList = mergedAttributes

20+attributesFromList = V.fromList -- . L.nub

23− where

24− mergedAttributes = V.reverse $ V.foldr (\attr acc -> if containsAttributeName (attributeName attr) acc then

25− acc

26− else

27− acc `V.snoc` attr

28− ) V.empty $ V.fromList attrList

29− containsAttributeName name attrs = isJust $ V.find (\attr -> attributeName attr == name) attrs

30

21

31attributeName :: Attribute -> AttributeName

22attributeName :: Attribute -> AttributeName

32attributeName (Attribute name _) = name

23attributeName (Attribute name _) = name

ProjectM36/Base.hs+2

@@ -94,6 +94,7 @@ type RelVarName = StringType

94

95data RelationalExpr where

96 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr

97+ ExistingRelation :: Relation -> RelationalExpr

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

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

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

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

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

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

@@ -189,3 +190,4 @@ instance Eq Transaction where

189

190

190instance Ord Transaction where

191instance Ord Transaction where

191 compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB

192 compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB

193+

ProjectM36/Relation.hs+7−2

@@ -13,6 +13,7 @@ import ProjectM36.TupleSet

13import ProjectM36.Error

14import Prelude hiding (join)

15import qualified Data.Text as T

16+import qualified Control.Parallel.Strategies as P

16

17

17attributes :: Relation -> Attributes

18attributes :: Relation -> Attributes

18attributes (Relation attrs _ ) = attrs

19attributes (Relation attrs _ ) = attrs

@@ -201,7 +202,11 @@ attributesForRelval relvalAttrName (Relation attrs _) = case A.atomTypeForAttrib

201 _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName

202 _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName

202

203

203restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation

204restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation

204−restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset

205+--restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset

206+restrict rfilter (Relation attrs tupset) = Right $ Relation attrs processedTupSet

207+ where

208+ tupSetList = HS.toList tupset

209+ processedTupSet = HS.fromList ((filter rfilter tupSetList) `P.using` (P.parListChunk 1000 P.rdeepseq))

205

210

206--joins on columns with the same name- use rename to avoid this- base case: cartesian product

211--joins on columns with the same name- use rename to avoid this- base case: cartesian product

207--after changing from string atoms, there needs to be a type-checking step!

212--after changing from string atoms, there needs to be a type-checking step!

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

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

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

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

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

262matrixRelation attributeCount tupleCount = do

267matrixRelation attributeCount tupleCount = do

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

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

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

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

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

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

266 mkRelation attrs tupleSet

271 mkRelation attrs tupleSet

ProjectM36/Relation/Show/HTML.hs+5−4

@@ -7,12 +7,13 @@ import qualified Data.HashSet as HS

7import qualified Data.List as L

8import ProjectM36.Attribute

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

10+import qualified Data.Text as T

10import qualified Data.Text.IO as TIO

11import qualified Data.Text.IO as TIO

11

12

12attributesAsHTML :: Attributes -> Text

13attributesAsHTML :: Attributes -> Text

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

14+attributesAsHTML attrs = "<tr>" `append` (T.concat $ map oneAttrHTML attrNameList) `append` "</tr>"

14 where

15 where

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

16+ oneAttrHTML attrName = "<th>" `append` attrName `append` "</th>"

16 attrNameList = sortedAttributeNameList (attributeNameSet attrs)

17 attrNameList = sortedAttributeNameList (attributeNameSet attrs)

17

18

18relationAsHTML :: Relation -> Text

19relationAsHTML :: Relation -> Text

@@ -32,9 +33,9 @@ atomAsHTML (IntAtom int) = pack (show int)

32atomAsHTML (RelationAtom rel) = relationAsHTML rel

33atomAsHTML (RelationAtom rel) = relationAsHTML rel

33

34

34tupleAsHTML :: RelationTuple -> Text

35tupleAsHTML :: RelationTuple -> Text

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

36+tupleAsHTML tuple = "<tr>" `append` T.concat (L.map tupleFrag (tupleSortedAssocs tuple)) `append` "</tr>"

36 where

37 where

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

38+ tupleFrag tup = "<td>" `append` atomAsHTML (snd tup) `append` "</td>"

38

39

39tupleSetAsHTML :: RelationTupleSet -> Text

40tupleSetAsHTML :: RelationTupleSet -> Text

40tupleSetAsHTML tupSet = HS.foldr folder "" tupSet

41tupleSetAsHTML tupSet = HS.foldr folder "" tupSet

ProjectM36/RelationalExpression.hs+2

@@ -48,6 +48,8 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do

48 Right rel -> return $ Right rel

49 Left err -> return $ Left err

50

51+evalRelationalExpr (ExistingRelation rel) = return (Right rel)

52+

51evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

53evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

52 evald <- evalRelationalExpr relExpr

54 evald <- evalRelationalExpr relExpr

53 case evald of

55 case evald of

ProjectM36/StaticOptimizer.hs+2−1

@@ -14,6 +14,8 @@ import Data.Either (rights, lefts)

14applyStaticRelationalOptimization :: RelationalExpr -> DatabaseState (Either RelationalError RelationalExpr)

15applyStaticRelationalOptimization e@(MakeStaticRelation _ _) = return $ Right e

16

17+applyStaticRelationalOptimization e@(ExistingRelation _) = return $ Right e

18+

17applyStaticRelationalOptimization e@(RelationVariable _) = return $ Right e

19applyStaticRelationalOptimization e@(RelationVariable _) = return $ Right e

18

20

19--remove project of attributes which removes no attributes

21--remove project of attributes which removes no attributes

@@ -140,6 +142,5 @@ applyStaticDatabaseOptimization (MultipleExpr exprs) = do

140 --this error handling could be improved with some lifting presumably

142 --this error handling could be improved with some lifting presumably

141 --restore original context

143 --restore original context

142

144

143−

144applyStaticPredicateOptimization :: RestrictionPredicateExpr -> DatabaseState (Either RelationalError RestrictionPredicateExpr)

145applyStaticPredicateOptimization :: RestrictionPredicateExpr -> DatabaseState (Either RelationalError RestrictionPredicateExpr)

145applyStaticPredicateOptimization predicate = return $ Right predicate

146applyStaticPredicateOptimization predicate = return $ Right predicate

ProjectM36/TupleSet.hs+1−1

@@ -19,7 +19,7 @@ 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 chunkSize P.rdeepseq

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

23 chunkSize = HS.size tupleSet `div` 24

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

25 if length (lefts tupleList) > 0 then

TutorialD/Interpreter.hs+1−2

@@ -487,7 +487,7 @@ interpret context tutdstring = case parseString tutdstring of

487 Left err -> (Just err, context)

488 Right parsed -> runState (evaluator parsed) context

489 where

490− evaluator expr = do

490+ evaluator expr = do

491 optExpr <- applyStaticDatabaseOptimization expr

492 --case optExpr of

493 case optExpr of

@@ -499,7 +499,6 @@ interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseCont

499interpretNO context tutdstring = case parseString tutdstring of

500 Left err -> (Just err, context)

501 Right parsed -> runState (evalContextExpr parsed) context

502−

503

502

504-- for interpreter-specific operations

503-- for interpreter-specific operations

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

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

benchmark/bigrel.hs+28−9

@@ -3,35 +3,45 @@ import ProjectM36.Base

3import ProjectM36.Relation

4import ProjectM36.Tuple

5import ProjectM36.Relation.Show.CSV

6+import ProjectM36.Relation.Show.HTML

7+import TutorialD.Interpreter (interpret)

8+import ProjectM36.RelationalExpression

6import qualified Data.HashSet as HS

9import qualified Data.HashSet as HS

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

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

8import qualified Data.IntMap as IM

11import qualified Data.IntMap as IM

9import qualified Data.Hashable as Hash

12import qualified Data.Hashable as Hash

10import qualified Data.Vector as V

13import qualified Data.Vector as V

11import Options.Applicative

14import Options.Applicative

15+import Control.Monad.State

16+import qualified Data.Map as M

17+import qualified Data.Text.IO as TIO

18+import System.IO

12

19

13dumpcsv :: Relation -> IO ()

20dumpcsv :: Relation -> IO ()

14dumpcsv = BS.putStrLn . relationAsCSV

21dumpcsv = BS.putStrLn . relationAsCSV

15

22

23+data BigrelArgs = BigrelArgs Int Int String

24+

16parseAttributeCount :: Parser Int

25parseAttributeCount :: Parser Int

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

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

18

27

19parseTupleCount :: Parser Int

28parseTupleCount :: Parser Int

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

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

21−

22−parseArgs :: Parser (Int, Int)

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

24

30

31+parseTutD :: Parser String

32+parseTutD = strOption (short 'd' <> long "tutoriald")

33+

34+parseArgs :: Parser BigrelArgs

35+parseArgs = BigrelArgs <$> parseAttributeCount <*> parseTupleCount <*> parseTutD

25

36

26main :: IO ()

37main :: IO ()

27main = do

38main = do

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

39+ bigrelArgs <- execParser $ info (helper <*> parseArgs) fullDesc

29 --matrixRestrictRun

40 --matrixRestrictRun

30− matrixRun attributeCount tupleCount

41+ matrixRun bigrelArgs

31 --vectorMatrixRun

42 --vectorMatrixRun

32 --intmapMatrixRun

43 --intmapMatrixRun

33

44

34−-- takes 30 minutes to run and 1.1 GB

35matrixRestrictRun :: IO ()

45matrixRestrictRun :: IO ()

36matrixRestrictRun = do

46matrixRestrictRun = do

37 case matrixRelation 100 1000000 of

47 case matrixRelation 100 1000000 of

@@ -40,11 +50,20 @@ matrixRestrictRun = do

40 Left err -> putStrLn (show err)

50 Left err -> putStrLn (show err)

41 Right rel -> dumpcsv rel

51 Right rel -> dumpcsv rel

42

52

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

53+matrixRun :: BigrelArgs -> IO ()

44−matrixRun attributeCount tupleCount= do

54+matrixRun (BigrelArgs attributeCount tupleCount tutd) = do

45 case matrixRelation attributeCount tupleCount of

55 case matrixRelation attributeCount tupleCount of

46 Left err -> putStrLn (show err)

56 Left err -> putStrLn (show err)

57+ Right rel -> if tutd == "" then

47− Right rel -> putStrLn "Done"

58+ putStrLn "Done."

59+ else do

60+ let setx = Assign "x" (ExistingRelation rel)

61+ (_, context) = runState (evalContextExpr setx) dateExamples

62+ (err, context2) = interpret context tutd

63+ case err of

64+ Nothing -> TIO.putStrLn $ relationAsHTML ((relationVariables context2) M.! "x")

65+ Just err -> hPutStrLn stderr (show err)

66+

48

67

49intmapMatrixRun :: IO ()

68intmapMatrixRun :: IO ()

50intmapMatrixRun = do

69intmapMatrixRun = do