ebc44e6 · project-m36 · git.iko.soy

git.iko.soy/project-m36

import CSV with header

import TutorialD files

commitebc44e6f5cc15f9df7ce35448f19a09300ea5fd3 authorAgentM <agentm@themactionfaction.com> dateThu 23 Jul 2015, 22:53 (11 years ago) parent2106852

11 files changed+242−14

compare with master

unifiedsplit

ProjectM36/Atom.hs+25−1 ProjectM36/Relation/Parse/CSV.hs+49 TutorialD/Interpreter.hs+17−5 TutorialD/Interpreter/Base.hs+8 TutorialD/Interpreter/Import/Base.hs+14 TutorialD/Interpreter/Import/CSV.hs+31 TutorialD/Interpreter/Import/TutorialD.hs+27 TutorialD/Interpreter/RelationalExpr.hs−7 project-m36.cabal+15−1 test/Relation/Import/CSV.hs+29 test/TutorialD/Interpreter/Import/TutorialD.hs+27

ProjectM36/Atom.hs+25−1

@@ -2,6 +2,10 @@

22module ProjectM36.Atom where

33import ProjectM36.Base

44import ProjectM36.Error

5+import qualified Data.Text as T

6+import Text.Read (readMaybe)

7+import Data.Time.Format

8+import System.Locale

610relationForAtom :: Atom -> Either RelationalError Relation

711relationForAtom (RelationAtom rel) = Right rel

@@ -12,4 +16,24 @@ atomTypeForAtom (StringAtom _) = StringAtomType

1216atomTypeForAtom (IntAtom _) = IntAtomType

1317atomTypeForAtom (RelationAtom (Relation attributes _)) = RelationAtomType attributes

1418atomTypeForAtom (BoolAtom _) = BoolAtomType

15−atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType

19+atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType

20+

21+{- a generic string constructor for atoms

22+used by CSV relation generation

23+-}

24+atomFromString :: AtomType -> String -> Either RelationalError Atom

25+atomFromString StringAtomType strIn = Right $ StringAtom (T.pack strIn)

26+atomFromString IntAtomType strIn = case readMaybe strIn of

27+ Just i -> Right $ IntAtom i

28+ Nothing -> Left (ParseError "Failed to parse integer")

29+atomFromString BoolAtomType strIn = case strIn of

30+ "true" -> Right $ BoolAtom True

31+ "false" -> Right $ BoolAtom False

32+ _ -> Left (ParseError "Failed to parse boolean")

33+atomFromString (RelationAtomType _) _ = Left $ ParseError "Nested relation parsing not supported"

34+atomFromString DateTimeAtomType strIn =

35+ --deprecated in time 1.5- needs update for GHC 7.10

36+ case parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" strIn of

37+ Just utctime -> Right $ DateTimeAtom utctime

38+ Nothing -> Left $ ParseError "Failed to parse datetime"

39+atomFromString AnyAtomType _ = Left $ ParseError "Parsing AnyAtomType is not supported"

ProjectM36/Relation/Parse/CSV.hsnew file+49

@@ -0,0 +1,49 @@

1+module ProjectM36.Relation.Parse.CSV where

2+--parse Relations from CSV

3+import Data.Csv.Parser

4+import qualified Data.Vector as V

5+import Data.Char (ord)

6+import qualified Data.ByteString.Lazy as BS

7+import ProjectM36.Base

8+import ProjectM36.Relation

9+import ProjectM36.Atom

10+import ProjectM36.Error

11+import Data.Text.Encoding (decodeUtf8)

12+import qualified ProjectM36.Attribute as A

13+import qualified Data.Set as S

14+import Data.HashMap.Lazy as HM

15+import qualified Data.List as L

16+import qualified Data.Text as T

17+import Data.Attoparsec.ByteString.Lazy

18+

19+data CsvImportError = CsvParseError String |

20+ AttributeMappingError RelationalError |

21+ HeaderAttributeMismatchError (S.Set AttributeName)

22+ deriving (Show)

23+

24+csvDecodeOptions :: DecodeOptions

25+csvDecodeOptions = DecodeOptions {decDelimiter = fromIntegral (ord ',')}

26+

27+csvAsRelation :: BS.ByteString -> Attributes -> Either CsvImportError Relation

28+csvAsRelation inString attrs = case parse (csvWithHeader csvDecodeOptions) inString of

29+ Fail _ _ err -> Left (CsvParseError err)

30+ Done _ (headerRaw,vecMapsRaw) -> do

31+ let strHeader = V.map decodeUtf8 headerRaw

32+ strMapRecords = V.map convertMap vecMapsRaw

33+ convertMap hmap = HM.fromList $ L.map (\(k,v) -> (decodeUtf8 k, (T.unpack . decodeUtf8) v)) (HM.toList hmap)

34+ attrNames = V.map A.attributeName attrs

35+ attrNameSet = S.fromList (V.toList attrNames)

36+ headerSet = S.fromList (V.toList strHeader)

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

38+ makeTupleList tupMap = V.toList $ V.map (\attr -> makeAtom (A.atomType attr) (tupMap HM.! (A.attributeName attr))) attrs

39+ makeAtom aType strIn = case atomFromString aType strIn of

40+ Left err -> Left $ AttributeMappingError err

41+ Right atom -> Right atom

42+ case attrNameSet == headerSet of

43+ False -> Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)

44+ True -> do

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

46+ case mkRelationFromList attrs tupleList of

47+ Left err -> Left (AttributeMappingError err)

48+ Right rel -> Right rel

49+

TutorialD/Interpreter.hs+17−5

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

44import TutorialD.Interpreter.RODatabaseContextOperator

55import TutorialD.Interpreter.DatabaseExpr

66import TutorialD.Interpreter.TransactionGraphOperator

7+import TutorialD.Interpreter.Import.CSV

8+import TutorialD.Interpreter.Import.TutorialD

9+import TutorialD.Interpreter.Import.Base

710import ProjectM36.Base

811import ProjectM36.Relation.Show.Term

912import ProjectM36.TransactionGraph

@@ -24,13 +27,15 @@ graph ops are read-write operations which change the transaction graph

2427data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |

2528 DatabaseExprOp DatabaseExpr |

2629 GraphOp TransactionGraphOperator |

27− ROGraphOp ROTransactionGraphOperator

30+ ROGraphOp ROTransactionGraphOperator |

31+ ImportOp DataImportOperator

2832

2933interpreterParserP :: Parser ParsedOperation

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

31− liftM GraphOp (transactionGraphOpP <* eof) <|>

32− liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>

33− liftM DatabaseExprOp (databaseExprOpP <* eof)

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

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

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

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

3439

3540promptText :: DisconnectedTransaction -> TransactionGraph -> StringType

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

@@ -72,7 +77,14 @@ evalTutorialD conn expr = case expr of

7277 case evalROGraphOp discon graph execOp of

7378 Left err -> barf err

7479 Right rel -> return $ DisplayResult $ showRelation rel

75−

80+

81+ (ImportOp execOp) -> do

82+ (DisconnectedTransaction _ context) <- disconnectedTransaction conn

83+ exprErr <- evalDataImportOperator execOp context

84+ case exprErr of

85+ Left err -> barf err

86+ Right dbexpr -> evalTutorialD conn (DatabaseExprOp dbexpr)

87+

7688 where

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

7890

TutorialD/Interpreter/Base.hs+8

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

1010import qualified Data.Vector as V

1111import qualified Data.Text.IO as TIO

1212import System.IO

13+import Control.Applicative ((<*),(*>))

1314

1415lexer :: Token.TokenParser ()

1516lexer = Token.makeTokenParser tutD

@@ -78,3 +79,10 @@ displayOpResult (DisplayIOResult ioout) = ioout

7879displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " `T.append` err)

7980displayOpResult QuietSuccessResult = return ()

8081

82+quotedChar :: Parser Char

83+quotedChar = noneOf "\""

84+ <|> try (string "\"\"" >> return '"')

85+

86+quotedString :: Parser String

87+quotedString = string "\"" *> many quotedChar <* string "\""

88+

TutorialD/Interpreter/Import/Base.hsnew file+14

@@ -0,0 +1,14 @@

1+module TutorialD.Interpreter.Import.Base where

2+import ProjectM36.Base

3+import ProjectM36.Error

4+import ProjectM36.Relation

5+import qualified Data.Map as M

7+data DataImportOperator = DataImportOperator FilePath (FilePath -> DatabaseContext -> IO (Either RelationalError DatabaseExpr))

9+evalDataImportOperator :: DataImportOperator -> DatabaseContext -> IO (Either RelationalError DatabaseExpr)

10+evalDataImportOperator (DataImportOperator path importFunc) context = do

11+ imported <- importFunc path context

12+ case imported of

13+ Left err -> return $ Left err

14+ Right dbexprs -> return $ Right dbexprs

TutorialD/Interpreter/Import/CSV.hsnew file+31

@@ -0,0 +1,31 @@

1+module TutorialD.Interpreter.Import.CSV where

2+import TutorialD.Interpreter.Import.Base

3+import ProjectM36.Base

4+import ProjectM36.Error

5+import ProjectM36.Relation

6+import ProjectM36.Relation.Parse.CSV

7+import qualified Data.ByteString.Lazy as BS

8+import qualified Data.Map as M

9+import qualified Data.Text as T

10+import Text.Parsec.String

11+import TutorialD.Interpreter.Base

12+

13+importCSVRelation :: RelVarName -> FilePath -> DatabaseContext -> IO (Either RelationalError DatabaseExpr)

14+importCSVRelation relVarName pathIn context = do

15+ case M.lookup relVarName (relationVariables context) of

16+ Nothing -> return $ Left (RelVarNotDefinedError relVarName)

17+ Just targetRel -> do

18+ --TODO: handle filesystem errors

19+ csvData <- BS.readFile pathIn

20+ case csvAsRelation csvData (attributes targetRel) of

21+ Left err -> return $ Left (ParseError $ T.pack (show err))

22+ Right csvRel -> return $ Right (Insert relVarName (ExistingRelation csvRel))

23+

24+importCSVP :: Parser DataImportOperator

25+importCSVP = do

26+ reserved ":importcsv"

27+ path <- quotedString

28+ whiteSpace

29+ relVarName <- identifier

30+ return $ DataImportOperator path (importCSVRelation (T.pack relVarName))

31+

TutorialD/Interpreter/Import/TutorialD.hsnew file+27

@@ -0,0 +1,27 @@

1+module TutorialD.Interpreter.Import.TutorialD where

2+import ProjectM36.Base

3+import TutorialD.Interpreter.Import.Base

4+import TutorialD.Interpreter.Base

5+import TutorialD.Interpreter.DatabaseExpr

6+import Text.Parsec.String

7+import Text.Parsec

8+import ProjectM36.Error

9+import Data.Either

10+import qualified Data.Text as T

11+--import a file containing TutorialD database context expressions

12+

13+importTutorialD :: FilePath -> DatabaseContext -> IO (Either RelationalError DatabaseExpr)

14+importTutorialD pathIn _ = do

15+ tutdData <- readFile pathIn

16+ let dbexprsErr = map (parse databaseExprP "") (lines tutdData)

17+ errs = lefts dbexprsErr

18+ case errs of

19+ err:_ -> return $ Left (ParseError (T.pack (show err)))

20+ [] -> return $ Right (MultipleExpr (rights dbexprsErr))

21+

22+tutdImportP :: Parser DataImportOperator

23+tutdImportP = do

24+ reserved ":importtutd"

25+ path <- quotedString

26+ whiteSpace

27+ return $ DataImportOperator path importTutorialD

TutorialD/Interpreter/RelationalExpr.hs−7

@@ -234,16 +234,9 @@ functionAtomExprP = do

234234relationalAtomExprP :: Parser AtomExpr

235235relationalAtomExprP = RelationAtomExpr <$> relExprP

236236

237−quotedChar :: Parser Char

238−quotedChar = noneOf "\""

239− <|> try (string "\"\"" >> return '"')

240−

241237stringAtomP :: Parser Atom

242238stringAtomP = liftA (StringAtom . T.pack) quotedString

243239

244−quotedString :: Parser String

245−quotedString = string "\"" *> many quotedChar <* string "\""

246−

247240dateTimeAtomP :: Parser Atom

248241dateTimeAtomP = do

249242 dateString' <- try $ do

project-m36.cabal+15−1

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

77Cabal-Version: >= 1.2

99Library

10− Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,gnuplot,binary,filepath,directory,vector-binary-instances,unix,temporary,stm,time,hashable-time,old-locale

10+ Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava ==0.4.*,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,gnuplot,binary,filepath,directory,vector-binary-instances,unix,temporary,stm,time,hashable-time,old-locale,attoparsec

1111 Exposed-Modules: ProjectM36.Error,

1212 ProjectM36.Transaction,

1313 ProjectM36.TransactionGraph,

@@ -28,6 +28,7 @@ Library

2828 ProjectM36.Relation.Show.Term,

2929 ProjectM36.Relation.Show.CSV,

3030 ProjectM36.Relation.Show.Gnuplot,

31+ ProjectM36.Relation.Parse.CSV,

3132 ProjectM36.Client

3233 GHC-Options: -Wall -rtsopts

3334

@@ -80,8 +81,21 @@ Test-Suite test-transactiongraph-persist

8081 Build-Depends: base,HUnit,Cabal

8182 GHC-Options: -Wall

8283

84+Test-Suite test-relation-import-csv

85+ type: exitcode-stdio-1.0

86+ main-is: test/Relation/Import/CSV.hs

87+ Build-Depends: base,HUnit,Cabal

88+ GHC-Options: -Wall

89+

90+Test-Suite test-tutoriald-import-tutoriald

91+ type: exitcode-stdio-1.0

92+ main-is: test/TutorialD/Interpreter/Import/TutorialD.hs

93+ Build-Depends: base,HUnit,Cabal

94+ GHC-Options: -Wall

95+

8396benchmark bench

8497 type: exitcode-stdio-1.0

8598 main-is: benchmark/Relation.hs

8699 build-depends: base,criterion

87100 GHC-Options: -Wall -rtsopts

101+

test/Relation/Import/CSV.hsnew file+29

@@ -0,0 +1,29 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Test.HUnit

3+import ProjectM36.Base

4+import ProjectM36.Relation.Parse.CSV

5+import ProjectM36.Relation

6+import qualified ProjectM36.Attribute as A

7+import System.Exit

8+import qualified Data.Text.Lazy as T

9+import Data.Text.Lazy.Encoding

10+

11+main :: IO ()

12+main = do

13+ tcounts <- runTestTT $ TestList [testCSVSuccess]

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

15+

16+testCSVSuccess :: Test

17+testCSVSuccess = TestCase $ do

18+ let sampleCSV = (encodeUtf8 . T.pack) "S#,CITY,STATUS,SNAME\n\"S8\",\"Boston\",150,\"Mike\"\nS9,Londonderry,170,Perry"

19+ expectedAttrs = A.attributesFromList [Attribute "S#" StringAtomType,

20+ Attribute "SNAME" StringAtomType,

21+ Attribute "STATUS" IntAtomType,

22+ Attribute "CITY" StringAtomType]

23+ expectedRel = mkRelationFromList expectedAttrs [

24+ [StringAtom "S9", StringAtom "Perry", IntAtom 170, StringAtom "Londonderry"],

25+ [StringAtom "S8", StringAtom "Mike", IntAtom 150, StringAtom "Boston"]]

26+ case csvAsRelation sampleCSV expectedAttrs of

27+ Left err -> assertFailure $ show err

28+ Right csvRel -> assertEqual "csv->relation" expectedRel (Right csvRel)

29+

test/TutorialD/Interpreter/Import/TutorialD.hsnew file+27

@@ -0,0 +1,27 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Test.HUnit

3+import ProjectM36.Base

4+import qualified ProjectM36.Attribute as A

5+import TutorialD.Interpreter.Import.TutorialD

6+import qualified Data.HashSet as HS

7+import System.Exit

8+import System.IO.Temp

9+import qualified ProjectM36.DatabaseContext as DC

10+import qualified Data.Vector as V

11+import System.IO

12+

13+

14+main :: IO ()

15+main = do

16+ tcounts <- runTestTT $ TestList [testTutdImport]

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

18+

19+testTutdImport :: Test

20+testTutdImport = TestCase $ do

21+ withSystemTempFile "m.tutd" $ \path handle -> do

22+ hPutStrLn handle "x:=relation{tuple{a 5,b \"spam\"}}"

23+ hClose handle

24+ let expectedExpr = MultipleExpr [Assign "x" (ExistingRelation (Relation expectedAttrs $ HS.singleton (RelationTuple expectedAttrs $ V.fromList [IntAtom 5, StringAtom "spam"])))]

25+ expectedAttrs = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" StringAtomType]

26+ imported <- importTutorialD path DC.empty

27+ assertEqual "import tutd" (Right expectedExpr) imported