@@ -1,21 +1,26 @@
11module ProjectM36.Relation.Parse.CSV where
22--parse Relations from CSV
3+import ProjectM36.Base
4+import ProjectM36.Error
5+import ProjectM36.Relation
6+import ProjectM36.AtomType
7+import qualified ProjectM36.Attribute as A
8+
39import Data.Csv.Parser
410import qualified Data.Vector as V
5−import Data.Char (ord)
11+import Data.Char (ord, isUpper, isSpace)
612import qualified Data.ByteString.Lazy as BS
7−import ProjectM36.Base
8−import ProjectM36.Relation
9−import ProjectM36.Error
1013import Data.Text.Encoding (decodeUtf8)
11−import qualified ProjectM36.Attribute as A
1214import qualified Data.Set as S
13−import Data.HashMap.Lazy as HM
15+import qualified Data.HashMap.Lazy as HM
1416import qualified Data.List as L
1517import qualified Data.Text as T
16−import Data.Attoparsec.ByteString.Lazy
17−import ProjectM36.Atom
18+import qualified Data.Attoparsec.ByteString.Lazy as APBL
19+import qualified Data.Attoparsec.Text as APT
1820import Control.Arrow
21+import Text.Read hiding (parens)
22+import Control.Applicative
23+import Data.Either
1924
2025data CsvImportError = CsvParseError String |
2126 AttributeMappingError RelationalError |
@@ -25,25 +30,23 @@ data CsvImportError = CsvParseError String |
2530csvDecodeOptions :: DecodeOptions
2631csvDecodeOptions = DecodeOptions {decDelimiter = fromIntegral (ord ',')}
2732
28−--special case from Text- outer quotes are *not* required in CSV, so we have to add them to make it parseable
29−makeAtomFromCSVText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom
30−makeAtomFromCSVText attrName aType textIn = makeAtomFromText attrName aType $ if aType == TextAtomType then
31− "\"" `T.append` textIn `T.append` "\""
32− else
33− textIn
34−
35−csvAsRelation :: BS.ByteString -> Attributes -> Either CsvImportError Relation
36−csvAsRelation inString attrs = case parse (csvWithHeader csvDecodeOptions) inString of
37− Fail _ _ err -> Left (CsvParseError err)
38− Done _ (headerRaw,vecMapsRaw) -> do
33+csvAsRelation :: Attributes -> TypeConstructorMapping -> BS.ByteString -> Either CsvImportError Relation
34+csvAsRelation attrs tConsMap inString = case APBL.parse (csvWithHeader csvDecodeOptions) inString of
35+ APBL.Fail _ _ err -> Left (CsvParseError err)
36+ APBL.Done _ (headerRaw,vecMapsRaw) -> do
3937 let strHeader = V.map decodeUtf8 headerRaw
4038 strMapRecords = V.map convertMap vecMapsRaw
4139 convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)
4240 attrNames = V.map A.attributeName attrs
4341 attrNameSet = S.fromList (V.toList attrNames)
4442 headerSet = S.fromList (V.toList strHeader)
43+ parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType <* APT.endOfInput) textIn of
44+ Left err -> Left (ParseError (T.pack err))
45+ Right eAtom -> eAtom
4546 makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]
46− makeTupleList tupMap = V.toList $ V.map (\attr -> either (Left . AttributeMappingError) Right $ makeAtomFromCSVText (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) attrs
47+ makeTupleList tupMap = V.toList $ V.map (\attr ->
48+ either (Left . AttributeMappingError) Right $
49+ parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) attrs
4750 if attrNameSet == headerSet then do
4851 tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)
4952 case mkRelationFromList attrs tupleList of
@@ -52,3 +55,103 @@ csvAsRelation inString attrs = case parse (csvWithHeader csvDecodeOptions) inStr
5255 else
5356 Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)
5457
58+
59+parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser (Either RelationalError Atom)
60+parseCSVAtomP _ _ IntegerAtomType = (Right . IntegerAtom) <$> APT.decimal
61+parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal
62+parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double
63+parseCSVAtomP _ _ TextAtomType = do
64+ s <- quotedString <|> takeToEndOfData
65+ pure (Right (TextAtom s))
66+parseCSVAtomP _ _ DayAtomType = do
67+ dString <- T.unpack <$> takeToEndOfData
68+ case readMaybe dString of
69+ Nothing -> fail ("invalid Day string: " ++ dString)
70+ Just date -> pure (Right (DayAtom date))
71+parseCSVAtomP _ _ DateTimeAtomType = do
72+ dString <- T.unpack <$> takeToEndOfData
73+ case readMaybe dString of
74+ Nothing -> fail ("invalid Date string: " ++ dString)
75+ Just date -> pure (Right (DateTimeAtom date))
76+parseCSVAtomP _ _ ByteStringAtomType = do
77+ bsString <- T.unpack <$> takeToEndOfData
78+ case readMaybe bsString of
79+ Nothing -> fail ("invalid ByteString string: " ++ bsString)
80+ Just bs -> pure (Right (ByteStringAtom bs))
81+parseCSVAtomP _ _ BoolAtomType = do
82+ bString <- T.unpack <$> takeToEndOfData
83+ case readMaybe bString of
84+ Nothing -> fail ("invalid BoolAtom string: " ++ bString)
85+ Just b -> pure (Right (BoolAtom b))
86+parseCSVAtomP attrName tConsMap (IntervalAtomType iType) = do
87+ begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)
88+ eBeginv <- parseCSVAtomP attrName tConsMap iType
89+ case eBeginv of
90+ Left err -> pure (Left err)
91+ Right beginv -> do
92+ _ <- APT.char ','
93+ eEndv <- parseCSVAtomP attrName tConsMap iType
94+ case eEndv of
95+ Left err -> pure (Left err)
96+ Right endv -> do
97+ end <- (APT.char ']' >> pure False) <|> (APT.char ')' >> pure True)
98+ pure (Right (IntervalAtom beginv endv begin end))
99+parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) = do
100+ dConsName <- capitalizedIdentifier
101+ APT.skipSpace
102+ --we need to look up the name right away in order to determine the types of the following arguments
103+ -- grab the data constructor
104+ case findDataConstructor dConsName tConsMap of
105+ Nothing -> pure (Left (NoSuchDataConstructorError dConsName))
106+ Just (_, dConsDef) ->
107+ -- identify the data constructor's expected atom type args
108+ case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of
109+ Left err -> pure (Left err)
110+ Right argAtomTypes -> do
111+ atomArgs <- mapM (\argTyp -> let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp <* APT.skipSpace in
112+ case argTyp of
113+ ConstructedAtomType _ _ ->
114+ parens parseNextAtom <|>
115+ parseNextAtom
116+ _ -> parseNextAtom
117+ ) argAtomTypes
118+ case lefts atomArgs of
119+ [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs)))
120+ errs -> pure (Left (someErrors errs))
121+parseCSVAtomP attrName _ (RelationAtomType _) = pure (Left (RelationValuedAttributesNotSupportedError [attrName]))
122+parseCSVAtomP _ _ (TypeVariableType x) = pure (Left (TypeConstructorTypeVarMissing x))
123+
124+capitalizedIdentifier :: APT.Parser T.Text
125+capitalizedIdentifier = do
126+ fletter <- APT.satisfy isUpper APT.<?> "capitalized data constructor letter"
127+ rest <- APT.takeWhile (\c -> not (isSpace c || c == ')')) APT.<?> "data constructor name"
128+ pure (fletter `T.cons` rest)
129+
130+--read data for Text.Read parser but be wary of end of interval blocks
131+takeToEndOfData :: APT.Parser T.Text
132+takeToEndOfData = APT.takeWhile (APT.notInClass ",)]")
133+
134+parens :: APT.Parser a -> APT.Parser a
135+parens p = do
136+ APT.skip (== '(')
137+ APT.skipSpace
138+ v <- p
139+ APT.skipSpace
140+ APT.skip (== ')')
141+ pure v
142+
143+quotedString :: APT.Parser T.Text
144+quotedString = do
145+ let escapeMap = [('"','"'), ('n', '\n'), ('r', '\r')]
146+ APT.skip (== '"')
147+ (_, s) <- APT.runScanner [] (\prevl nextChar -> case prevl of
148+ [] -> Just [nextChar]
149+ chars | last chars == '\\' ->
150+ case lookup nextChar escapeMap of
151+ Nothing -> Just (chars ++ [nextChar]) --there is no escape sequence, so leave backslash + char
152+ Just escapeVal -> Just (init chars ++ [escapeVal]) -- nuke the backslash and add the escapeVal
153+ | nextChar == '"' -> Nothing
154+ | otherwise -> Just (chars ++ [nextChar]))
155+ APT.skip (== '"')
156+ pure (T.pack s)
157+