@@ -1,21 +1,27 @@
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
511import Data.Char (ord)
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
1315import 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
24+import Data.Char
1925
2026data CsvImportError = CsvParseError String |
2127 AttributeMappingError RelationalError |
@@ -25,25 +31,23 @@ data CsvImportError = CsvParseError String |
2531csvDecodeOptions :: DecodeOptions
2632csvDecodeOptions = DecodeOptions {decDelimiter = fromIntegral (ord ',')}
2733
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
34+csvAsRelation :: Attributes -> TypeConstructorMapping -> BS.ByteString -> Either CsvImportError Relation
35+csvAsRelation attrs tConsMap inString = case APBL.parse (csvWithHeader csvDecodeOptions) inString of
36+ APBL.Fail _ _ err -> Left (CsvParseError err)
37+ APBL.Done _ (headerRaw,vecMapsRaw) -> do
3938 let strHeader = V.map decodeUtf8 headerRaw
4039 strMapRecords = V.map convertMap vecMapsRaw
4140 convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)
4241 attrNames = V.map A.attributeName attrs
4342 attrNameSet = S.fromList (V.toList attrNames)
4443 headerSet = S.fromList (V.toList strHeader)
44+ parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType <* APT.endOfInput) textIn of
45+ Left err -> Left (ParseError (T.pack err))
46+ Right eAtom -> eAtom
4547 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
48+ makeTupleList tupMap = V.toList $ V.map (\attr ->
49+ either (Left . AttributeMappingError) Right $
50+ parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) attrs
4751 if attrNameSet == headerSet then do
4852 tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)
4953 case mkRelationFromList attrs tupleList of
@@ -52,3 +56,101 @@ csvAsRelation inString attrs = case parse (csvWithHeader csvDecodeOptions) inStr
5256 else
5357 Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)
5458
59+
60+parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser (Either RelationalError Atom)
61+parseCSVAtomP _ _ IntegerAtomType = (Right . IntegerAtom) <$> APT.decimal
62+parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal
63+parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double
64+parseCSVAtomP _ _ TextAtomType = Right . TextAtom <$>
65+ (quotedString <|>
66+ takeToEndOfData)
67+parseCSVAtomP _ _ DayAtomType = do
68+ dString <- T.unpack <$> takeToEndOfData
69+ case readMaybe dString of
70+ Nothing -> fail ("invalid Day string: " ++ dString)
71+ Just date -> pure (Right (DayAtom date))
72+parseCSVAtomP _ _ DateTimeAtomType = do
73+ dString <- T.unpack <$> takeToEndOfData
74+ case readMaybe dString of
75+ Nothing -> fail ("invalid Date string: " ++ dString)
76+ Just date -> pure (Right (DateTimeAtom date))
77+parseCSVAtomP _ _ ByteStringAtomType = do
78+ bsString <- T.unpack <$> takeToEndOfData
79+ case readMaybe bsString of
80+ Nothing -> fail ("invalid ByteString string: " ++ bsString)
81+ Just bs -> pure (Right (ByteStringAtom bs))
82+parseCSVAtomP _ _ BoolAtomType = do
83+ bString <- T.unpack <$> takeToEndOfData
84+ case readMaybe bString of
85+ Nothing -> fail ("invalid BoolAtom string: " ++ bString)
86+ Just b -> pure (Right (BoolAtom b))
87+parseCSVAtomP attrName tConsMap (IntervalAtomType iType) = do
88+ begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)
89+ eBeginv <- parseCSVAtomP attrName tConsMap iType
90+ case eBeginv of
91+ Left err -> pure (Left err)
92+ Right beginv -> do
93+ _ <- APT.char ','
94+ eEndv <- parseCSVAtomP attrName tConsMap iType
95+ case eEndv of
96+ Left err -> pure (Left err)
97+ Right endv -> do
98+ end <- (APT.char ']' >> pure False) <|> (APT.char ')' >> pure True)
99+ pure (Right (IntervalAtom beginv endv begin end))
100+parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) = do
101+ dConsName <- capitalizedIdentifier
102+ APT.skipSpace
103+ --we need to look up the name right away in order to determine the types of the following arguments
104+ -- grab the data constructor
105+ case findDataConstructor dConsName tConsMap of
106+ Nothing -> pure (Left (NoSuchDataConstructorError dConsName))
107+ Just (_, dConsDef) -> do
108+ -- identify the data constructor's expected atom type args
109+ case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of
110+ Left err -> pure (Left err)
111+ Right argAtomTypes -> do
112+ atomArgs <- mapM (\argTyp -> let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp <* APT.skipSpace in
113+ case argTyp of
114+ ConstructedAtomType _ _ ->
115+ (parens parseNextAtom) <|>
116+ parseNextAtom
117+ _ -> parseNextAtom
118+ ) argAtomTypes
119+ case lefts atomArgs of
120+ [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs)))
121+ errs -> pure (Left (someErrors errs))
122+parseCSVAtomP attrName _ (RelationAtomType _) = pure (Left (RelationValuedAttributesNotSupportedError [attrName]))
123+parseCSVAtomP _ _ (TypeVariableType x) = pure (Left (TypeConstructorTypeVarMissing x))
124+
125+capitalizedIdentifier :: APT.Parser T.Text
126+capitalizedIdentifier = do
127+ fletter <- APT.satisfy isUpper APT.<?> "capitalized data constructor letter"
128+ rest <- APT.takeWhile (\c -> not (isSpace c || c == ')')) APT.<?> "data constructor name"
129+ pure (fletter `T.cons` rest)
130+
131+--read data for Text.Read parser but be wary of end of interval blocks
132+takeToEndOfData :: APT.Parser T.Text
133+takeToEndOfData = APT.takeWhile (APT.notInClass ",)]")
134+
135+parens :: APT.Parser a -> APT.Parser a
136+parens p = do
137+ APT.skip (== '(')
138+ APT.skipSpace
139+ v <- p
140+ APT.skipSpace
141+ APT.skip (== ')')
142+ pure v
143+
144+quotedString :: APT.Parser T.Text
145+quotedString = do
146+ APT.skip (== '"')
147+ v <- APT.scan False (\prevEscape nextChar -> if nextChar == '"' && not prevEscape then
148+ Nothing
149+ else if nextChar == '\\' then
150+ Just True
151+ else
152+ Just False
153+ )
154+ APT.skip (== '"')
155+ pure v
156+