ebc44e6 · project-m36 · git.iko.soy

ProjectM36/Atom.hs+25−1

compare with master

unifiedsplit

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

2module ProjectM36.Atom where

3import ProjectM36.Base

4import ProjectM36.Error

5+import qualified Data.Text as T

6+import Text.Read (readMaybe)

7+import Data.Time.Format

8+import System.Locale

5

9

6relationForAtom :: Atom -> Either RelationalError Relation

10relationForAtom :: Atom -> Either RelationalError Relation

7relationForAtom (RelationAtom rel) = Right rel

11relationForAtom (RelationAtom rel) = Right rel

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

12atomTypeForAtom (IntAtom _) = IntAtomType

16atomTypeForAtom (IntAtom _) = IntAtomType

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

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

14atomTypeForAtom (BoolAtom _) = BoolAtomType

18atomTypeForAtom (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

4import TutorialD.Interpreter.RODatabaseContextOperator

5import TutorialD.Interpreter.DatabaseExpr

6import TutorialD.Interpreter.TransactionGraphOperator

7+import TutorialD.Interpreter.Import.CSV

8+import TutorialD.Interpreter.Import.TutorialD

9+import TutorialD.Interpreter.Import.Base

7import ProjectM36.Base

10import ProjectM36.Base

8import ProjectM36.Relation.Show.Term

11import ProjectM36.Relation.Show.Term

9import ProjectM36.TransactionGraph

12import ProjectM36.TransactionGraph

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

24data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |

27data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |

25 DatabaseExprOp DatabaseExpr |

28 DatabaseExprOp DatabaseExpr |

26 GraphOp TransactionGraphOperator |

29 GraphOp TransactionGraphOperator |

27− ROGraphOp ROTransactionGraphOperator

30+ ROGraphOp ROTransactionGraphOperator |

31+ ImportOp DataImportOperator

28

32

29interpreterParserP :: Parser ParsedOperation

33interpreterParserP :: Parser ParsedOperation

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

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

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

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

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

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

33− liftM DatabaseExprOp (databaseExprOpP <* eof)

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

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

34

39

35promptText :: DisconnectedTransaction -> TransactionGraph -> StringType

40promptText :: DisconnectedTransaction -> TransactionGraph -> StringType

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

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

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

72 case evalROGraphOp discon graph execOp of

77 case evalROGraphOp discon graph execOp of

73 Left err -> barf err

78 Left err -> barf err

74 Right rel -> return $ DisplayResult $ showRelation rel

79 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+

76 where

88 where

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

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

78

90

TutorialD/Interpreter/Base.hs+8

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

10import qualified Data.Vector as V

11import qualified Data.Text.IO as TIO

12import System.IO

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

13

14

14lexer :: Token.TokenParser ()

15lexer :: Token.TokenParser ()

15lexer = Token.makeTokenParser tutD

16lexer = Token.makeTokenParser tutD

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

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

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

79displayOpResult QuietSuccessResult = return ()

80displayOpResult QuietSuccessResult = return ()

80

81

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

6+

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

8+

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

234relationalAtomExprP :: Parser AtomExpr

235relationalAtomExprP = RelationAtomExpr <$> relExprP

236

237−quotedChar :: Parser Char

238−quotedChar = noneOf "\""

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

240−

241stringAtomP :: Parser Atom

237stringAtomP :: Parser Atom

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

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

243

239

244−quotedString :: Parser String

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

246−

247dateTimeAtomP :: Parser Atom

240dateTimeAtomP :: Parser Atom

248dateTimeAtomP = do

241dateTimeAtomP = do

249 dateString' <- try $ do

242 dateString' <- try $ do

project-m36.cabal+15−1

@@ -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,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

11 Exposed-Modules: ProjectM36.Error,

12 ProjectM36.Transaction,

13 ProjectM36.TransactionGraph,

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

28 ProjectM36.Relation.Show.Term,

29 ProjectM36.Relation.Show.CSV,

30 ProjectM36.Relation.Show.Gnuplot,

31+ ProjectM36.Relation.Parse.CSV,

31 ProjectM36.Client

32 ProjectM36.Client

32 GHC-Options: -Wall -rtsopts

33 GHC-Options: -Wall -rtsopts

33

34

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

80 Build-Depends: base,HUnit,Cabal

81 Build-Depends: base,HUnit,Cabal

81 GHC-Options: -Wall

82 GHC-Options: -Wall

82

83

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+

83benchmark bench

96benchmark bench

84 type: exitcode-stdio-1.0

97 type: exitcode-stdio-1.0

85 main-is: benchmark/Relation.hs

98 main-is: benchmark/Relation.hs

86 build-depends: base,criterion

99 build-depends: base,criterion

87 GHC-Options: -Wall -rtsopts

100 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