d4fbf56 · project-m36 · git.iko.soy

ProjectM36/Base.hs−1

compare with master

unifiedsplit

@@ -19,7 +19,6 @@ import Data.Time.Clock

19import Data.Time.Clock.POSIX

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

21import Data.Hashable.Time ()

22−import Control.Monad (liftM)

23

22

24type StringType = T.Text

23type StringType = T.Text

25

24

ProjectM36/Error.hs+2

@@ -32,7 +32,9 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

32 | AtomTypeMismatchError AtomType AtomType

33 | AtomTypeCountError [AtomType] [AtomType]

34 | AtomFunctionTypeError AtomFunctionName Int AtomType AtomType --arg number

35+ | RelationValuedAttributesNotSupportedError [AttributeName]

35 | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

36 | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

37+ | ExportError T.Text

36 deriving (Show,Eq,Generic)

38 deriving (Show,Eq,Generic)

37

39

38instance NFData RelationalError where rnf = genericRnf

40instance NFData RelationalError where rnf = genericRnf

ProjectM36/Relation/Show/CSV.hs+16−3

@@ -1,14 +1,25 @@

1module ProjectM36.Relation.Show.CSV where

2import ProjectM36.Base

3+import ProjectM36.Attribute

3import Data.Csv

4import Data.Csv

4import ProjectM36.Tuple

5import ProjectM36.Tuple

5import qualified Data.HashSet as HS

6import qualified Data.HashSet as HS

6import qualified Data.ByteString.Lazy as BS

7import qualified Data.ByteString.Lazy as BS

7import qualified Data.Vector as V

8import qualified Data.Vector as V

9+import ProjectM36.Error

10+import qualified Data.Text.Encoding as TE

11+import qualified Data.Text as T

8

12

9--maybe support a header in the future

13--maybe support a header in the future

10−relationAsCSV :: Relation -> BS.ByteString

14+relationAsCSV :: Relation -> Either RelationalError BS.ByteString

11−relationAsCSV (Relation _ tupleSet) = tupleSetAsCSV tupleSet

15+relationAsCSV (Relation attrs tupleSet) = case relValAttrs of

16+ [] -> Right $ encodeHeader `BS.append` tupleSetAsCSV tupleSet

17+ attrs' -> Left $ RelationValuedAttributesNotSupportedError (map attributeName attrs')

18+ where

19+ --figure out how to make cassava responsible for printing the header even for non-named records or make NamedRecord instance for RelationTuple ?

20+ -- this will break on attribute names which need quoting

21+ encodeHeader = (BS.intercalate (BS.fromStrict . TE.encodeUtf8 . T.pack $ ",") $ V.toList $ V.map (BS.fromStrict . TE.encodeUtf8 . attributeName) attrs) `BS.append` (BS.fromStrict . TE.encodeUtf8 . T.pack) "\n"

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

12

23

13tupleSetAsCSV :: RelationTupleSet -> BS.ByteString

24tupleSetAsCSV :: RelationTupleSet -> BS.ByteString

14tupleSetAsCSV tupleSet = encode (HS.toList tupleSet)

25tupleSetAsCSV tupleSet = encode (HS.toList tupleSet)

@@ -21,6 +32,8 @@ instance ToField Atom where

21 toField (StringAtom atom) = toField atom

32 toField (StringAtom atom) = toField atom

22 toField (IntAtom atom) = toField atom

33 toField (IntAtom atom) = toField atom

23 toField (DateTimeAtom atom) = toField (show atom)

34 toField (DateTimeAtom atom) = toField (show atom)

35+ toField (DateAtom atom) = toField (show atom)

36+ toField (DoubleAtom atom) = toField atom

24− toField (RelationAtom _) = undefined -- CSV does not support nested relations- this should likely be detected and rejected

37+ toField (RelationAtom _) = undefined -- CSV does not support nested relations

25

38

26

39

TutorialD/Interpreter.hs+18−4

@@ -4,9 +4,14 @@ import TutorialD.Interpreter.Base

4import TutorialD.Interpreter.RODatabaseContextOperator

5import TutorialD.Interpreter.DatabaseExpr

6import TutorialD.Interpreter.TransactionGraphOperator

7+

7import TutorialD.Interpreter.Import.CSV

8import TutorialD.Interpreter.Import.CSV

8import TutorialD.Interpreter.Import.TutorialD

9import TutorialD.Interpreter.Import.TutorialD

9import TutorialD.Interpreter.Import.Base

10import TutorialD.Interpreter.Import.Base

11+

12+import TutorialD.Interpreter.Export.CSV

13+import TutorialD.Interpreter.Export.Base

14+

10import ProjectM36.Base

15import ProjectM36.Base

11import ProjectM36.Relation.Show.Term

16import ProjectM36.Relation.Show.Term

12import ProjectM36.TransactionGraph

17import ProjectM36.TransactionGraph

@@ -28,14 +33,16 @@ data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |

28 DatabaseExprOp DatabaseExpr |

33 DatabaseExprOp DatabaseExpr |

29 GraphOp TransactionGraphOperator |

34 GraphOp TransactionGraphOperator |

30 ROGraphOp ROTransactionGraphOperator |

35 ROGraphOp ROTransactionGraphOperator |

31− ImportOp DataImportOperator

36+ ImportOp DataImportOperator |

37+ ExportOp DataExportOperator

32

38

33interpreterParserP :: Parser ParsedOperation

39interpreterParserP :: Parser ParsedOperation

34interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>

40interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>

35 liftM GraphOp (transactionGraphOpP <* eof) <|>

41 liftM GraphOp (transactionGraphOpP <* eof) <|>

36 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>

42 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>

37 liftM DatabaseExprOp (databaseExprOpP <* eof) <|>

43 liftM DatabaseExprOp (databaseExprOpP <* eof) <|>

38− liftM ImportOp ((importCSVP <|> tutdImportP) <* eof)

44+ liftM ImportOp ((importCSVP <|> tutdImportP) <* eof) <|>

45+ liftM ExportOp (exportCSVP <* eof)

39

46

40promptText :: DisconnectedTransaction -> TransactionGraph -> StringType

47promptText :: DisconnectedTransaction -> TransactionGraph -> StringType

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

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

@@ -63,13 +70,13 @@ evalTutorialD conn expr = case expr of

63 maybeErr <- executeDatabaseContextExpr conn execOp

70 maybeErr <- executeDatabaseContextExpr conn execOp

64 case maybeErr of

71 case maybeErr of

65 Just err -> barf err

72 Just err -> barf err

66− Nothing -> return $ QuietSuccessResult

73+ Nothing -> return QuietSuccessResult

67

74

68 (GraphOp execOp) -> do

75 (GraphOp execOp) -> do

69 maybeErr <- executeGraphExpr conn execOp

76 maybeErr <- executeGraphExpr conn execOp

70 case maybeErr of

77 case maybeErr of

71 Just err -> barf err

78 Just err -> barf err

72− Nothing -> return $ QuietSuccessResult

79+ Nothing -> return QuietSuccessResult

73

80

74 (ROGraphOp execOp) -> do

81 (ROGraphOp execOp) -> do

75 discon <- disconnectedTransaction conn

82 discon <- disconnectedTransaction conn

@@ -84,6 +91,13 @@ evalTutorialD conn expr = case expr of

84 case exprErr of

91 case exprErr of

85 Left err -> barf err

92 Left err -> barf err

86 Right dbexpr -> evalTutorialD conn (DatabaseExprOp dbexpr)

93 Right dbexpr -> evalTutorialD conn (DatabaseExprOp dbexpr)

94+

95+ (ExportOp execOp) -> do

96+ (DisconnectedTransaction _ context) <- disconnectedTransaction conn

97+ exprErr <- evalDataExportOperator execOp context

98+ case exprErr of

99+ Just err -> barf err

100+ Nothing -> return QuietSuccessResult

87

101

88 where

102 where

89 barf err = return $ DisplayErrorResult (T.pack (show err))

103 barf err = return $ DisplayErrorResult (T.pack (show err))

TutorialD/Interpreter/Export/Base.hsnew file+9

@@ -0,0 +1,9 @@

1+module TutorialD.Interpreter.Export.Base where

2+import ProjectM36.Base

3+import ProjectM36.Error

4+

5+data DataExportOperator = DataExportOperator (DatabaseContext -> FilePath -> IO (Maybe RelationalError)) FilePath

6+

7+evalDataExportOperator :: DataExportOperator -> DatabaseContext -> IO (Maybe RelationalError)

8+evalDataExportOperator (DataExportOperator exportFunc pathOut) context = exportFunc context pathOut

9+

TutorialD/Interpreter/Export/CSV.hsnew file+34

@@ -0,0 +1,34 @@

1+module TutorialD.Interpreter.Export.CSV where

2+import ProjectM36.Relation.Show.CSV

3+import TutorialD.Interpreter.Export.Base

4+import TutorialD.Interpreter.RelationalExpr

5+import TutorialD.Interpreter.Base

6+import ProjectM36.Base

7+import ProjectM36.RelationalExpression

8+import ProjectM36.Error

9+import Control.Monad.State (evalState)

10+import Text.Parsec.String

11+import qualified Data.ByteString.Lazy as BS

12+import Control.Exception (try)

13+import qualified Data.Text as T

14+

15+exportCSVP :: Parser DataExportOperator

16+exportCSVP = do

17+ reserved ":exportcsv"

18+ exportExpr <- relExprP

19+ path <- quotedString

20+ return $ DataExportOperator (exportRelationCSV exportExpr) path

21+

22+exportRelationCSV :: RelationalExpr -> DatabaseContext -> FilePath -> IO (Maybe RelationalError)

23+exportRelationCSV relExpr context pathOut = do

24+ let exportRel = evalState (evalRelationalExpr relExpr) context

25+ case exportRel of

26+ Left err -> return $ Just err

27+ Right exportRel' -> do

28+ case relationAsCSV exportRel' of

29+ Left err -> return $ Just err

30+ Right csvData -> do

31+ writeResult <- try (BS.writeFile pathOut csvData) :: IO (Either IOError ())

32+ case writeResult of

33+ Left err -> return $ Just (ExportError $ T.pack (show err))

34+ Right _ -> return Nothing

TutorialD/Interpreter/RelationalExpr.hs+3

@@ -22,6 +22,9 @@ atomTypeP :: Parser AtomType

22atomTypeP = (reserved "char" *> return StringAtomType) <|>

23 (reserved "int" *> return IntAtomType) <|>

24 (reserved "datetime" *> return DateTimeAtomType) <|>

25+ (reserved "date" *> return DateAtomType) <|>

26+ (reserved "double" *> return DoubleAtomType) <|>

27+ (reserved "bool" *> return BoolAtomType) <|>

25 (RelationAtomType <$> (reserved "relation" *> makeAttributesP))

28 (RelationAtomType <$> (reserved "relation" *> makeAttributesP))

26

29

27--used in projection

30--used in projection

benchmark/bigrel.hs+3−1

@@ -20,7 +20,9 @@ import System.IO

20import Control.Monad.State

21

22dumpcsv :: Relation -> IO ()

23−dumpcsv = BS.putStrLn . relationAsCSV

23+dumpcsv rel = case relationAsCSV rel of

24+ Left err -> hPutStrLn stderr (show err)

25+ Right bsData -> BS.putStrLn bsData

24

26

25data BigrelArgs = BigrelArgs Int Int String

27data BigrelArgs = BigrelArgs Int Int String

26

28

project-m36.cabal+6

@@ -93,6 +93,12 @@ Test-Suite test-tutoriald-import-tutoriald

93 Build-Depends: base,HUnit,Cabal

94 GHC-Options: -Wall

95

96+Test-Suite test-relation-export-csv

97+ type: exitcode-stdio-1.0

98+ main-is: test/Relation/Export/CSV.hs

99+ Build-Depends: base,HUnit,Cabal

100+ GHC-Options: -Wall

101+

96benchmark bench

102benchmark bench

97 type: exitcode-stdio-1.0

103 type: exitcode-stdio-1.0

98 main-is: benchmark/Relation.hs

104 main-is: benchmark/Relation.hs