git.iko.soy/project-m36
on master help sign in
add relation-based CSV export with ":exportcsv"

-add test to round-trip relations via CSV

commitd4fbf566ec93c791cda51b4790fac9fbea8fcbb8 authorAgentM <agentm@themactionfaction.com> dateSat 25 Jul 2015, 10:55 (11 years ago) parent4747a1a
9 files changed+91−9
compare with master
unifiedsplit
ProjectM36/Base.hs−1 ProjectM36/Error.hs+2 ProjectM36/Relation/Show/CSV.hs+16−3 TutorialD/Interpreter.hs+18−4 TutorialD/Interpreter/Export/Base.hs+9 TutorialD/Interpreter/Export/CSV.hs+34 TutorialD/Interpreter/RelationalExpr.hs+3 benchmark/bigrel.hs+3−1 project-m36.cabal+6
ProjectM36/Base.hs−1
@@ -19,7 +19,6 @@ import Data.Time.Clock
1919import Data.Time.Clock.POSIX
2020import Data.Time.Calendar (Day,toGregorian,fromGregorian)
2121import Data.Hashable.Time ()
22−import Control.Monad (liftM)
2322
2423type StringType = T.Text
2524
ProjectM36/Error.hs+2
@@ -32,7 +32,9 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)
3232 | AtomTypeMismatchError AtomType AtomType
3333 | AtomTypeCountError [AtomType] [AtomType]
3434 | AtomFunctionTypeError AtomFunctionName Int AtomType AtomType --arg number
35+ | RelationValuedAttributesNotSupportedError [AttributeName]
3536 | 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
3638 deriving (Show,Eq,Generic)
3739
3840instance NFData RelationalError where rnf = genericRnf
ProjectM36/Relation/Show/CSV.hs+16−3
@@ -1,14 +1,25 @@
11module ProjectM36.Relation.Show.CSV where
22import ProjectM36.Base
3+import ProjectM36.Attribute
34import Data.Csv
45import ProjectM36.Tuple
56import qualified Data.HashSet as HS
67import qualified Data.ByteString.Lazy as BS
78import qualified Data.Vector as V
9+import ProjectM36.Error
10+import qualified Data.Text.Encoding as TE
11+import qualified Data.Text as T
812
913--maybe support a header in the future
10−relationAsCSV :: Relation -> BS.ByteString
11−relationAsCSV (Relation _ tupleSet) = tupleSetAsCSV tupleSet
14+relationAsCSV :: Relation -> Either RelationalError BS.ByteString
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
1223
1324tupleSetAsCSV :: RelationTupleSet -> BS.ByteString
1425tupleSetAsCSV tupleSet = encode (HS.toList tupleSet)
@@ -21,6 +32,8 @@ instance ToField Atom where
2132 toField (StringAtom atom) = toField atom
2233 toField (IntAtom atom) = toField atom
2334 toField (DateTimeAtom atom) = toField (show atom)
24− toField (RelationAtom _) = undefined -- CSV does not support nested relations- this should likely be detected and rejected
35+ toField (DateAtom atom) = toField (show atom)
36+ toField (DoubleAtom atom) = toField atom
37+ toField (RelationAtom _) = undefined -- CSV does not support nested relations
2538
2639
TutorialD/Interpreter.hs+18−4
@@ -4,9 +4,14 @@ import TutorialD.Interpreter.Base
44import TutorialD.Interpreter.RODatabaseContextOperator
55import TutorialD.Interpreter.DatabaseExpr
66import TutorialD.Interpreter.TransactionGraphOperator
7+
78import TutorialD.Interpreter.Import.CSV
89import TutorialD.Interpreter.Import.TutorialD
910import TutorialD.Interpreter.Import.Base
11+
12+import TutorialD.Interpreter.Export.CSV
13+import TutorialD.Interpreter.Export.Base
14+
1015import ProjectM36.Base
1116import ProjectM36.Relation.Show.Term
1217import ProjectM36.TransactionGraph
@@ -28,14 +33,16 @@ data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
2833 DatabaseExprOp DatabaseExpr |
2934 GraphOp TransactionGraphOperator |
3035 ROGraphOp ROTransactionGraphOperator |
31− ImportOp DataImportOperator
36+ ImportOp DataImportOperator |
37+ ExportOp DataExportOperator
3238
3339interpreterParserP :: Parser ParsedOperation
3440interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
3541 liftM GraphOp (transactionGraphOpP <* eof) <|>
3642 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>
3743 liftM DatabaseExprOp (databaseExprOpP <* eof) <|>
38− liftM ImportOp ((importCSVP <|> tutdImportP) <* eof)
44+ liftM ImportOp ((importCSVP <|> tutdImportP) <* eof) <|>
45+ liftM ExportOp (exportCSVP <* eof)
3946
4047promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
4148promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
@@ -63,13 +70,13 @@ evalTutorialD conn expr = case expr of
6370 maybeErr <- executeDatabaseContextExpr conn execOp
6471 case maybeErr of
6572 Just err -> barf err
66− Nothing -> return $ QuietSuccessResult
73+ Nothing -> return QuietSuccessResult
6774
6875 (GraphOp execOp) -> do
6976 maybeErr <- executeGraphExpr conn execOp
7077 case maybeErr of
7178 Just err -> barf err
72− Nothing -> return $ QuietSuccessResult
79+ Nothing -> return QuietSuccessResult
7380
7481 (ROGraphOp execOp) -> do
7582 discon <- disconnectedTransaction conn
@@ -84,6 +91,13 @@ evalTutorialD conn expr = case expr of
8491 case exprErr of
8592 Left err -> barf err
8693 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
87101
88102 where
89103 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
2222atomTypeP = (reserved "char" *> return StringAtomType) <|>
2323 (reserved "int" *> return IntAtomType) <|>
2424 (reserved "datetime" *> return DateTimeAtomType) <|>
25+ (reserved "date" *> return DateAtomType) <|>
26+ (reserved "double" *> return DoubleAtomType) <|>
27+ (reserved "bool" *> return BoolAtomType) <|>
2528 (RelationAtomType <$> (reserved "relation" *> makeAttributesP))
2629
2730--used in projection
benchmark/bigrel.hs+3−1
@@ -20,7 +20,9 @@ import System.IO
2020import Control.Monad.State
2121
2222dumpcsv :: 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
2426
2527data BigrelArgs = BigrelArgs Int Int String
2628
project-m36.cabal+6
@@ -93,6 +93,12 @@ Test-Suite test-tutoriald-import-tutoriald
9393 Build-Depends: base,HUnit,Cabal
9494 GHC-Options: -Wall
9595
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+
96102benchmark bench
97103 type: exitcode-stdio-1.0
98104 main-is: benchmark/Relation.hs